الـعيدروس

السلام عليكم هل هكذا ماتريد غير نطاق البحث عبر كود حدث الاوراق محرك 1بحث.rar

المكتبي يمكنك من المشاركة بشكل طبيعي ولكن ليس الجميع بنفس الوقت يعلمون على الملف مجرد ان تفتح الملف ويحاول اخر يفتح يطلع ان الملف للقراءه فقط ولايمكنك التعديل والاضافة

السلام عليكم بهذا الشكل Public X Sub Macro2() X = "Release" End Sub بالامكان ارجاع قيمة المتغير الى قيمة فارغة عند اغلاق المصنف وعند النقر على الزر يحط قيمتة Release وهكذا بحدث الصفحة Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.Column = 4 And ActiveCell.Row > 5 Then If Not X = Empty Then MsgBox "الكود يعمل بطريقة صحيحة" End If End If End Sub

وعليكم السلام ورحمة الله وبركاته مرحبا بك اخونا azera 1 بين اخوتك ماتصبو اليه ارى تحميل Office 365 والاشتراك فيه بمبلغ زهيد سنوي 400 ريال سعودي وبالامكان شراء تراخيص عبر مواقع اخرى ارخص

وهذا رابط بالمنتدى موضوع شرح المصفوفات للاستاذ ياسر خليل

array هذي عبارة عن جدول او جداول ubound للاشارة عن البعد الاخير سوى لاعمدة او للصفوف للجداول مثلا استخدام Ubound للـ Array A = Array(1,2,3,4,5) لمعرفة عدد بيانات المتغر A msgbox Ubound(A) طبيعة الحالة النتيجة 4 لان اي جدول يبداء بصفر وليس بـ 1 الا اذا تم الاشارة في بداية المودويل بالجملة Option Base 1 كالتالي Option Base 1 Sub Test() Dim A A = Array(1, 2, 3, 4, 5) MsgBox UBound(A) ' 5 End Sub او بدون الاشارة كالتالي النتيجة 4 Sub Test() Dim A A = Array(1, 2, 3, 4, 5) MsgBox UBound(A) ' 4 End Sub وبطبيعة الحالة عند استخدام الحلقات التكرارية يستخدم للمصفوفات للاشارة للبداية بكلمة Lbound بدلاً الخطاء اذا اشرت بـ 0 او 1 وللاشارة بالنهاية بـ Ubound كالمثال التالي Option Base 1 Sub Test() Dim A A = Array(1, 2, 3, 4, 5) For i = LBound(A) To UBound(A) MsgBox A(i) ' 1,2,3,4,5 Next i End Sub ولها استخدامات اخرى بإمكانك مراجعة موضوع استاذنا الغالي عبدالله باقشير لشرح المصفوفات

تفضل انقر على الزر تجدة في ورقة تايم شت المصنف111.xls

السلام عليكم جرب الكود التالي بدائي اذا عدد الصفحات قليلة الكود Ref_Cel لاصلاح الخلايا التي التواريخ فيها لاتقراء بالامكان استخدامه منفصل Private Const تايم_شت = "تايم شيت " ' مسمى صفحة تقرير حركة البصمة Private Const الرقم_الوظيفي = "$B$2" ' مرجع خلية رقم الوظف بالصفحات Private Const سجل_الايام = "$B$6:$B$35" ' مدى التواريخ بصفحة الموظف Dim Tim_Sht As Worksheet Private Sub Ref_Cel() Dim Rng As Range Dim i With Tim_Sht Lr = .Cells(.Rows.Count, "A").End(xlUp).Row Set Rng = Range("B2:B" & Lr) Rng.Select Rng.NumberFormat = "dd/mm/yyyy" Rng.Select For i = 1 To Rng.Rows.Count SendKeys "{F2}", True SendKeys "{ENTER}", True Next i End With End Sub Sub Alidroos() Dim Lr As Long Dim Rng_Sht As Range Dim My_Rng As Range Dim Sht_All As Worksheet Dim Num_JOP Dim Rng_Date As Range Dim Date_JoP As Date Dim Tim_C As Date Dim Tim_D As Date Dim Row_Date Dim Tl_Row As Long Dim Nm_Sh As String '-------------------------------------------------------------------------------------------- '>>>>>>>>>>>>>>>> Apple_Speed False '>>>>>>>>>>>>>>>> '-------------------------------------------------------------------------------------------- Set Tim_Sht = Sheets(تايم_شت) ' ورقة تقرير حركة ماكنة البصمة '-------------------------------------------------------------------------------------------- Lr = Tim_Sht.Cells(Tim_Sht.Rows.Count, "A").End(xlUp).Row ' اخر صف به بيانات '-------------------------------------------------------------------------------------------- Ref_Cel ' لخلل بعض الاسطر التاريخ غير صحيح ' يوقف بعد اول تنفيذ '-------------------------------------------------------------------------------------------- Set Rng_Sht = Tim_Sht.Range("A2:A" & Lr) ' مدى بيانات تقرير حركة ماكنة البصمة '-------------------------------------------------------------------------------------------- For Each My_Rng In Rng_Sht ' حلقة تكرارية لمدى تقرير البصمة '-------------------------------------------------------------------------------------------- For Each Sht_All In Sheets ' حلقة تكرارية لصفحات الملف '-------------------------------------------------------------------------------------------- If Not Sht_All.Name = تايم_شت Then ' شرط تجاوز صفحة تقرير ماكنة البصمة '-------------------------------------------------------------------------------------------- Num_JOP = Sht_All.[B2] ' الرقم الوظيفي من صفحة الموظف الخاصة '-------------------------------------------------------------------------------------------- If My_Rng = Num_JOP Then ' اذا الرقم الوظيفي يطابق الذي فالصفحات '-------------------------------------------------------------------------------------------- ' Tl_Row = My_Rng.Row ' رقم سطر بيانات الحركة للبصمة '-------------------------------------------------------------------------------------------- Nm_Sh = Sht_All.Name ' اسم الصفحة الخاصة بالموظف '-------------------------------------------------------------------------------------------- Date_JoP = Format(My_Rng.Offset(0, 1), "dd/mm/yyyy") '' تاريخ الماكنة '-------------------------------------------------------------------------------------------- My_Rng.Offset(0, 1).Interior.Color = RGB(238, 219, 243) '' لون السطر المرحل '-------------------------------------------------------------------------------------------- Tim_C = My_Rng.Offset(0, 2) 'C' وقت حضور' '-------------------------------------------------------------------------------------------- Tim_D = My_Rng.Offset(0, 3) 'D' وقت انصراف' '-------------------------------------------------------------------------------------------- For Each Rng_Date In Sheets(Nm_Sh).Range(سجل_الايام) ' حلقة تكرارية لعمود التواريخ بصفحات الموظفين '-------------------------------------------------------------------------------------------- If Rng_Date = Date_JoP Then ' شرط تطابق تاريخ التقرير والصفحات '-------------------------------------------------------------------------------------------- Row_Date = Rng_Date.Row ' سطر التاريخ في سجل الموظف '-------------------------------------------------------------------------------------------- Sht_All.Cells(Row_Date, "D") = Tim_C ' C' ترحيل عمود '-------------------------------------------------------------------------------------------- Sht_All.Cells(Row_Date, 4).Interior.Color = RGB(238, 219, 243) ' لون المرحل '-------------------------------------------------------------------------------------------- Sht_All.Cells(Row_Date, "E") = Tim_D ' D' ترحيل عمود '-------------------------------------------------------------------------------------------- Sht_All.Cells(Row_Date, 5).Interior.Color = RGB(238, 219, 243) ' لون المرحل '-------------------------------------------------------------------------------------------- End If '-------------------------------------------------------------------------------------------- Next Rng_Date '-------------------------------------------------------------------------------------------- End If '-------------------------------------------------------------------------------------------- End If '-------------------------------------------------------------------------------------------- Next Sht_All '-------------------------------------------------------------------------------------------- Next My_Rng '-------------------------------------------------------------------------------------------- '<<<<<<<<<<<<<<<<< Apple_Speed True '<<<<<<<<<<<<<<<<< End Sub Private Sub Apple_Speed(Bl As Boolean) With Application .Calculation = IIf(Bl, -4105, -4135) .ScreenUpdating = Bl .EnableEvents = Bl End With End Sub

السلام عليكم حسب ملفك اظن يحتاج تحدد اوقات الحضور اوقات الانصراف مثال اوقات الحضور 07:00 ص حتى 13:00 م اوقات الانصراف 14:00 م حتى 21:00 م او اذا النظام فترات تحدد مجموعة فترات بحيث يعتمد الترحيل بموجبها مجموعة 1 اوقات الحضور 07:00 ص حتى 10:00 ص اوقات الانصراف 10:01 ص حتى 14:00 م مجموعة 2 اوقات الحضور 14:01 م حتى 16:00 م اوقات الانصراف 16:01 م حتى 21:00 م

لم استخدمها بإمكانك مسحها اذا ماتستخدمها

السلام عليكم مشكور على كلماتك الطيبه جرب المرفق امل ان يفي بالغرض fatoura2.rar

السلام عليكم ان وجدت الوقت اليوم اعمل عليه او غداً اتمنى تغير اسمك في البروفايل الى عربي تحياتي لك

السلام عليكم اضافة الى حل الاخ مصطفى شرف كود ان شاء الله يفي بالغرض ' اعمدة الجمع من عمود Private Const On_C As Integer = 4 ' الى عمود Private Const End_C As Integer = 7 ' مسمى عمود التكرار Private Const Colum = "C" Sub Ali_Def() Dim Lr As Long, Rw As Long Dim Col As Long Dim DelRNG As Range Application.ScreenUpdating = False Lr = Range(Colum & Rows.Count).End(xlUp).Row Set DelRNG = Range(Colum & Lr + 10) For Rw = 2 To Lr If Application.WorksheetFunction.CountIf(Range(Colum & 2 & ":" & Colum & Rw), _ Range(Colum & Rw)) > 1 Then Set DelRNG = Union(DelRNG, Range(Colum & Rw)) Else ' For Col = On_C To End_C Cells(Rw, Col) = Application.WorksheetFunction.SumIf(Range(Colum & ":" & Colum), Range(Colum & Rw), Columns(Col)) Next Col End If Next Rw DelRNG.EntireRow.Delete xlShiftUp Set DelRNG = Nothing Application.ScreenUpdating = True End Sub

السلام عليكم هذا تعدل على الكود mmmmmmmmmta3rif_cod بإستخدام النسخ واللصق ان شاء الله يفي بالغرض Sub mmmmmmmmmta3rif_cod() ' مربوط بالفيلكوأب الي في سطر 9 في صفحة استعلام المبيعات Application.ScreenUpdating = False ' للتسريع Application.EnableEvents = False ' للتسريع Application.Calculation = xlCalculationManual ' للتسريع Sheets("استعلام_المبيعات").Unprotect "" ' فك الحماية Sheets("المبيعات").Unprotect "" ' فك الحماية Dim Sh As Worksheet Dim Sh1 As Worksheet Dim Mx, i, Rr, Z, ii Dim Nu, Cu, r_o, r, Lr Dim Rn As Range Set Sh = Sheets("المبيعات"): Set Sh1 = Sheets("استعلام_المبيعات") Mx = Application.WorksheetFunction.CountA([I11:I5000]) Nu = Sh1.[i11] If Mx = 0 Then Exit Sub If Sh1.[i2] = "" Then MsgBox "حقل رقم الفاتورة فارغ !!", vbExclamation, "تنبية !!!": Exit Sub Lr = Sh.Cells(Sh.Rows.Count, "I").End(xlUp).Row For i = 2 To Lr r = Sh.Cells(i, "i") If r = Nu Then ii = ii + 1 If ii = 1 Then r_o = Sh.Cells(i, "i").Row Cu = Application.CountIf(Sh.Range("I2:I" & Lr), Nu) If Cu = Mx Then Sh1.Range("A11:J" & Sh1.Cells(Sh1.Rows.Count, "I").End(xlUp).Row).Copy Sh.Range("A" & r_o).PasteSpecial xlPasteValues Application.CutCopyMode = False Exit For Else For Rr = r_o To r_o + Cu If Rn Is Nothing Then Set Rn = Sh.Range("A" & Rr) Else Set Rn = Union(Rn, Sh.Range("A" & Rr)) End If Next Rr Lr = Sh1.Cells(Sh1.Rows.Count, "I").End(xlUp).Row If Mx > Cu Then Rn.EntireRow.Delete Z = Mx - Cu Sh.Rows(r_o & ":" & r_o + Z).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sh1.Range("A11:J" & Lr).Copy Sh.Range("A" & r_o).PasteSpecial xlPasteValues: Application.CutCopyMode = False Exit For Else Rn.EntireRow.Delete Z = Cu - Mx Sh.Rows(r_o & ":" & r_o + Z).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sh1.Range("A11:J" & Lr).Copy Sh.Range("A" & r_o).PasteSpecial xlPasteValues: Application.CutCopyMode = False Exit For End If End If End If Next i Application.ScreenUpdating = True ' للتسريع Application.EnableEvents = True ' للتسريع Application.Calculation = xlCalculationAutomatic ' للتسريع End Sub وان لديك استفسارات اطرحها ولن يقصر معك الجميع تحياتي

وعليكم السلام برجاء اعادة رفع الملف لم استطيع فتحه يظهر رسالة بأنه للقراءه فقط

السلام عليكم اخي الكريم حاتم مشكور على كلماتك الطيبه هذه تعديلات على حدث Private Sub TextBox1000_Change() Private Sub TextBox1000_Change() If TextBox1000.Value = "" Then ListBox1.Clear: Exit Sub Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 10).End(xlUp).Row For Each c In x.Range("D10:D" & SS) b = InStr(c, TextBox1000) If Trim(c) Like TextBox1000 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 4) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row k = k + 1 End If Next c Next x End Sub وحدث Private Sub ListBox1_Click() Private Sub ListBox1_Click() For I = 0 To ListBox1.ListCount If ListBox1.Selected(I) = True Then For j = 1 To 32 Controls("TextBox" & j).Text = Sheets(ListBox1.List(I, 1)).Cells(ListBox1.List(I, 2), j) Next j r = ListBox1.List(I, 1) Exit For End If Next I End Sub ان شاء الله يعمل معك كما ترجو تحياتي

اذا امكن ارفاق ملف وبه شرح ماتريد وحبذا الملف الذي تريد تطبيق الكود عليه تلافياً للوقت لمن اراد المشاركة

الكود صحيح عندك فقط عرض النتيجه في الليست بوكس في السطر التالي لم تشير لمتغير الورقة ListBox1.List(k, 0) = Cells(c.Row, 4) بيكون بهذا الشكل ListBox1.List(k, 0) = x.Cells(c.Row, 4)

السلام عليكم الى حلول الاخوه الاحبه لاثراء الموضوع تفضل الكود التالي Sub Cmpre_Ali() Dim List_a, Ar(), Cnt&, R& '------- List_a = Range("a2").CurrentRegion.Resize(, 2).Offset(1).Value '------- With CreateObject("Scripting.Dictionary") .CompareMode = vbTextCompare For R = 1 To UBound(List_a, 1) If (Not IsEmpty(List_a(R, 1))) * (Not .exists(List_a(R, 1))) Then .Add List_a(R, 1), Nothing Next ReDim Ar(1 To UBound(List_a, 1), 1 To 1) For R = 1 To UBound(List_a, 1) If Not IsEmpty(List_a(R, 2)) Then If Not .exists(List_a(R, 2)) Then Cnt = Cnt + 1: Ar(Cnt, 1) = List_a(R, 2) Else .Remove List_a(R, 2) End If End If Next If Cnt > 0 Then Range("C1").Offset(1, 1).Resize(Cnt).Value = Ar If .Count > 0 Then Range("C1").Offset(1).Resize(.Count).Value = Application.Transpose(.keys) Erase Ar End With End Sub تحياتي

السلام عليكم الاخ الحبيب ابراهيم ابو ليله اريد مدى الداتا ومدخلاته كما في ملفك الاصلي لمعرفة اعمدة البيانات كما واقع ملفك وخلايا ادخال الشروط ونتائج البحث في اي مكان

السلام عليكم الورقة محميه الغي الحمايه وارفق الملف مره اخرى وحبذا توضيح طلبك على الورقة ليسهل تنفيذ طلبك لمن اراد المشاركه تحياتي

أضف السطر التالي على الكود Range("G5:G1000").NumberFormat = "@" وهذا الكود تبعك ومضاف عليه السطر Range("F5:G1000").Select ActiveWorkbook.Worksheets("Groups").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Groups").Sort.SortFields.Add Key:=Range("G5:G1000") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortTextAsNumbers '---- Range("G5:G1000").NumberFormat = "@" '---- With ActiveWorkbook.Worksheets("Groups").Sort .SetRange Range("F5:G1000") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' تحياتي

السلام عليكم تسمية الحلقات التكراريه استبدلها لموقعها الصحيح For myMonth = 1 To 12 For rw = 13 To 262 For col = 8 To 49 If Sheets(myMonth).Cells(rw, "B").Value = Cells(rw, "c") Then MySum = MySum + Sheets(myMonth).Cells(rw, col_1).Value Next myMonth Next rw Next col هكذا بعد التصحيح الى ذالك اخطاء في الاقواس في بعض اسطر الكود تم تعديلها اكتشفها بنفسك Sub CalculateSums2() Dim MySum, myMonth, rw, col MySum = 0 For myMonth = 1 To 12 For rw = 13 To 262 For col = 8 To 49 If Sheets(myMonth).Cells(rw, "B").Value = Cells(rw, "c") Then MySum = MySum + Sheets(myMonth).Cells(rw, col).Value Next col Next rw Next myMonth ActiveSheet.Cells(rw, col) = MySum ActiveSheet.Range("H13").Select End Sub تحياتي

السلام عليكم ارفق ملف اخي الكريم وشرح مبسط على الملف وان شاء الله خير

اخي الحبيب ياسر خليل حفظك الله فعلاً اخي اختفيت عنا فتره لك وحشه ونحن الحمد لله نسأل عنكم واشكرك على مرورك العطر وكلماتك الطيبه الاخ الفاضل ابو زيد الشكر لله تقبلو تحياتي وشكري