سليم حاصبيا

يمكن الحل بواسطة الماكرو الكود Option Explicit Sub Salim_Order() With Sheets("ورقة1") If ActiveSheet.Name <> .Name Then Exit Sub Dim Ful_Rg As Range Dim Part_Rg As Range Dim My_Number: My_Number = [i2] Dim How_many: How_many = [k2] Dim K%, x%, m%: m = 2 Dim last_row If Not IsNumeric(How_many) Or How_many < 1 Then: How_many = 1 How_many = Int(How_many) If Not IsNumeric(My_Number) Or My_Number < 0 Then: My_Number = 0 My_Number = Int(My_Number) If My_Number >= Application.CountA(Range("A:A")) Then: My_Number = 0 .Range("E2", Range("E1").End(4)).ClearContents Set Ful_Rg = .Range("a1", Range("a1").End(4)) Set Part_Rg = Ful_Rg.Resize(Ful_Rg.Rows.Count - My_Number) For x = 1 To How_many - 1 .Range("e" & m).Resize(Part_Rg.Rows.Count).Value = _ Part_Rg.Value last_row = Cells(Rows.Count, "e").End(3).Row m = last_row + 1 Next .Range("e" & m) _ .Resize(Ful_Rg.Rows.Count).Value = Ful_Rg.Value End With End Sub الملف مرفق salim_Macro_For_repetition.xlsm

يمكنك اضافة و تعديل ما تشاء من الاسماء كله سوف يحدّث بالنسبة offest لم اجربها

جرب هذه المعادلة =INDEX(A:A,MOD(ROWS($A$1:A1)-1,COUNTA(A:A))+1) الملف مرفق salim_formula.xlsx

بعد اذن اخي علي هذا الملف (بعض التطوير بالنسبة للمعادلات) تم حماية المعادلات لعدم العبث بها عن طريق الخطأ قسيمة مشترك salim.xlsm

من المعروف ان الدالة Sum تتجاهل النصوص والفراغات (في الخلايا) لذلك يمكن استعمالها =SUM(A2:B12)

اريد اسم الموظف مرة واحدة فقط فى العمود كله هذا ما بفعله الملف المرفق من قبلي

ربما يكون المطلوب tekrarموظفين.xlsx

جرب هذا الملف الاجازات salim.xls

تم معالجة الامر الفهرس_New.xlsm

تمت معالجة الامر (مع الترتيب الأبجدي للاسماء) Badil (1).xlsm

هذه المعادلة =IF( A2="",""," مديونية من تاريخ " & TEXT(A2,"dd/mm/yyyy") & " حتى تاريخ ")

لك ما تريد _(تم تبديل الملف لان جحمه كبير جداً مما يعيق تنفيذ الماكرو) الكودين Option Explicit Sub FiND_DATA() Dim i%: i = 2 Dim arr, k%: k = 1 Dim H% Dim rg As Object Dim My_Table As Range: Set My_Table = Sijjel.Range("a1:L100") Salim.Cells.Clear Set rg = CreateObject("system.collections.arraylist") With rg Do Until Sijjel.Range("E" & i) = vbNullString If Not .contains(Sijjel.Range("E" & i).Value) And _ Application.CountIf(Sijjel.Range("E2:E" & i), Sijjel.Range("E" & i)) = 1 Then .Add Sijjel.Range("E" & i).Value End If i = i + 1 Loop Salim.Range("q1").Formula = "اسم المنتسب" '==================== For i = 0 To rg.Count - 1 Salim.Range("q2") = rg.Item(i) My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Salim.Range("Q1:q2"), _ CopyToRange:=Salim.Range("A" & k) H = Salim.Cells(Rows.Count, 5).End(3).Row k = H + 3 Next End With Salim.Range("q1:q2") = vbNullString Find_emPty End Sub '''''''''''''''''''''''''''''''''''''''' Sub Find_emPty() Dim lre%: lre = Salim.Cells(Rows.Count, "E").End(3).Row Dim arr1(), arr2() Dim i%, k%: k = 1 'Dim m%: m = 2 For i = 2 To lre If Salim.Cells(i, "e") = vbNullString Then ReDim Preserve arr1(1 To k): arr1(k) = Salim.Cells(i, "e").Row k = k + 1 i = i + 1 End If Next '====================================== Dim rg As Range Dim txt$ Dim f_addres$ txt = "اسم المنتسب" Dim m%: m = 1 Dim x x = Salim.Cells(Rows.Count, "E").End(3).Row Set rg = Range("E1:e" & x).Find(txt, after:=Cells(x, 5), LookIn:=xlValues, lookat:=xlPart) If Not rg Is Nothing Then f_addres = rg.Row + 1 Do ReDim Preserve arr2(1 To m): arr2(m) = rg.Row + 1 m = m + 1 If m > x - 1 Then Exit Do Set rg = Range("E1:e" & x).FindNext(rg) Loop While rg.Row + 1 > f_addres Else End If ReDim Preserve arr1(1 To UBound(arr1) + 1) arr1(UBound(arr1)) = x + 1 For i = 1 To UBound(arr2) Cells(arr1(i), 1).Resize(, 12).Interior.ColorIndex = 6 Cells(arr1(i), 6) = Application.Sum(Range(Cells(arr2(i), 6), Cells(arr1(i) - 1, 6))) Cells(arr1(i), 7) = Application.Sum(Range(Cells(arr2(i), 7), Cells(arr1(i) - 1, 7))) Cells(arr1(i), 8) = Application.Sum(Range(Cells(arr2(i), 8), Cells(arr1(i) - 1, 8))) Cells(arr1(i), 9) = Application.Sum(Range(Cells(arr2(i), 9), Cells(arr1(i) - 1, 9))) Cells(arr1(i), 10) = Application.Sum(Range(Cells(arr2(i), 10), Cells(arr1(i) - 1, 10))) Cells(arr1(i), 11) = Application.Sum(Range(Cells(arr2(i), 11), Cells(arr1(i) - 1, 11))) Cells(arr1(i), 12) = Application.Sum(Range(Cells(arr1(i), 6), Cells(arr1(i), 11))) Next '================================== End Sub '============================= الملف مرفق Badil.xlsm

جرب هذا الماكرو (لا أعلم لماذا هذا الحجم اكثر للملف اكثر من 4 ميفا) Option Explicit Sub FiND_DATA() Dim i%: i = 2 Dim arr, k%: k = 1 Dim H% Dim rg As Object Dim My_Table As Range: Set My_Table = Sijjel.Range("d1:m100") Salim.Cells.Clear Set rg = CreateObject("system.collections.arraylist") With rg Do Until Sijjel.Range("F" & i) = vbNullString If Not .contains(Sijjel.Range("f" & i).Value) And _ Application.CountIf(Sijjel.Range("F2:f" & i), Sijjel.Range("F" & i)) = 1 Then .Add Sijjel.Range("F" & i).Value End If i = i + 1 Loop Salim.Range("q1").Formula = "اسم المنتسب" '==================== For i = 0 To rg.Count - 1 Salim.Range("q2") = rg.Item(i) My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Salim.Range("Q1:q2"), _ CopyToRange:=Salim.Range("A" & k) H = Salim.Cells(Rows.Count, 1).End(3).Row k = H + 3 Next End With Salim.Range("q1:q2") = vbNullString End Sub الملف مرفق صفحة Salim عملSALIM.xlsm

لك ما تريد percent _simple.xlsx

ربما كان المطلوب هذه المرة tas7i7_Formula.xlsx

لا ارى اي خطأ لاحظ المرفق التالي Salim 2.xlsx

جرب هذه المعادلة (Ctrl+Shift+Enter) =SUMPRODUCT(IFERROR(IF(FREQUENCY($B$2:$B$100,$B$2:$B$100),$B$2:$B$100,0),0)) الملف مرفق Salim (3).xlsx

كود اخر و اقصر (مع عدم السماح بكتابة أكثر او اقل من 11 رقماً في الخلية D8) Option Explicit Private Sub Worksheet_Deactivate() Dim my_rg As Range On Error Resume Next Set my_rg = Sheets("Sheet1") _ .Range("d5:d11").SpecialCells(4) On Error GoTo 0 If Not my_rg Is Nothing Then Sheets("Sheet1").Select MsgBox "There Are Empty Cells:" & my_rg.Address End If End Sub الملف مرفق No_Out_New.xlsm

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

جرب هذا الماكرو Option Explicit Private Sub Worksheet_Deactivate() Dim cont% Dim i%, st$ Dim sh_name$ sh_name = ActiveSheet.Name cont = Application.CountA(Sheets("Sheet1").Range("d5:d11")) If cont <> 7 Then For i = 5 To 11 If Me.Range("d" & i) = vbNullString Then st = st & Me.Range("d" & i).Address & " ," End If Next End If If st <> vbNullString Then Sheets("Sheet1").Select MsgBox "I can't leave the Sheet" & Chr(10) & "We have empty cells, :" _ & Chr(10) & Mid(st, 1, Len(st) - 2) & ".", 64 Else Sheets(sh_name).Select End If End Sub الملف مرفق No_Out.xlsm

عليك ان تصفر كل البيانات في الورقة 1(فقط الاعداد ) لمرة واحدة فقط و تبدأ من جديد لأن في الصفحة 1 يجري ما يلي 1-يتم ازالة كافة الاصناف مع الكودات الخاصة 2-يتم ادراج الاصناف المدرجة في الصفحة 2 مع الكودات الخاصة 3-كلما ادرجت صنفاً جديداً في الصفحة 2 و بعد تنفيذ الماكرو تتم اضافته الى الصفحة 1 مع الكود بنفس الترتيب

اكثرمن رائع اخي بن علية

لا مستحيل عند الاكسل الكود بعد تعديله ليعطي ارتباط تشعبي Option Explicit Sub Give_Data() If ActiveSheet.Name <> "DATA" Then Exit Sub Dim My_Sh As Worksheet Dim Rg_to_Copy As Range Dim cell_to_Copy As Range Dim m%: m = 5 Dim t%, x% Dim start_date As Date: start_date = Sheets("DATA").[c1] Dim final_date As Date: final_date = Sheets("DATA").[c2] With Sheets("DATA") .Range("a5:y" & Rows.Count).ClearContents .Range("a5:y" & Rows.Count).Interior.ColorIndex = 2 For Each My_Sh In Worksheets If My_Sh.Name = "DATA" Or My_Sh.Name = "ملاحظات" Then GoTo 1 Set Rg_to_Copy = My_Sh.Range("a6").CurrentRegion.Offset(1).Columns(1).Cells For Each cell_to_Copy In Rg_to_Copy cell_to_Copy.Resize(, 24).Interior.ColorIndex = 2 If cell_to_Copy.Offset(, 16) >= start_date _ And cell_to_Copy.Offset(, 16) <= final_date Then .Range("a" & m).Resize(, 24).Value = _ cell_to_Copy.Resize(, 24).Value cell_to_Copy.Resize(, 24).Interior.ColorIndex = 6 m = m + 1 t = t + 1 End If Next '======================= If t <> 0 Then x = .Cells(Rows.Count, 1).End(3).Row .Cells(x + 1, 6) = "حصيلة الورقة :" & My_Sh.Name .Cells(x + 1, 1).Resize(, 24).Interior.ColorIndex = 6 '=================== .Cells(x + 1, 10).Hyperlinks.Add Anchor:=.Cells(x + 1, 10), Address:="", _ SubAddress:=My_Sh.Name & "!A1", TextToDisplay:="Go To: " & My_Sh.Name .Cells(x + 1, 10).Font.Size = 16 '=================== m = x + 3 Else End If t = 0 '================= 1: Next End With End Sub الملف جاهز New_جلب حسب التاريخ.xlsm

تعديل على الماكرو Option Explicit Sub Give_Data() 'If ActiveSheet.Name <> "DATA" Then Exit Sub Dim My_Sh As Worksheet Dim Rg_to_Copy As Range Dim cell_to_Copy As Range Dim m%: m = 5 Dim t%, x% Dim start_date As Date: start_date = Sheets("DATA").[c1] Dim final_date As Date: final_date = Sheets("DATA").[c2] With Sheets("DATA") .Range("a5:y" & Rows.Count).ClearContents .Range("a5:y" & Rows.Count).Interior.ColorIndex = 2 For Each My_Sh In Worksheets If My_Sh.Name = "DATA" Or My_Sh.Name = "ملاحظات" Then Exit Sub Set Rg_to_Copy = My_Sh.Range("a6").CurrentRegion.Offset(1).Columns(1).Cells For Each cell_to_Copy In Rg_to_Copy cell_to_Copy.Resize(, 24).Interior.ColorIndex = 2 If cell_to_Copy.Offset(, 16) >= start_date _ And cell_to_Copy.Offset(, 16) >= final_date Then .Range("a" & m).Resize(, 24).Value = _ cell_to_Copy.Resize(, 24).Value cell_to_Copy.Resize(, 24).Interior.ColorIndex = 6 m = m + 1 t = t + 1 End If Next '======================= If t <> 0 Then x = .Cells(Rows.Count, 1).End(3).Row .Cells(x + 1, 6) = "حصيلة الورقة :" & My_Sh.Name .Cells(x + 1, 1).Resize(, 25).Interior.ColorIndex = 6 m = x + 3 Else End If t = 0 '================= Next End With End Sub

من المعروف ان الدالة Match تعطينا أول صف تراه في الجدول لكن بحيلة بسيطة يمكننا التغلب على هذه الدالة لتعطينا كل الصفوف (كل ذلك دون أخطاء N/A#) شاهد هذا الملف Multi_Match.xlsx