سليم حاصبيا

استبدل الى هذا الماكرو Sub TekrarList_With_choise() Application.ScreenUpdating = False Dim x As Long Dim dictionary As Object Dim my_rg As Range Dim My_number As Integer My_number = ActiveSheet.[f1] If Not IsNumeric(My_number) Or My_number <= 0 Then Exit Sub Else My_number = Int(My_number) End If If My_number = 0 Then My_number = 1 Set dictionary = CreateObject("scripting.dictionary") Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown)) ActiveSheet.Range("b:d").ClearContents Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة" On Error Resume Next For i = 1 To my_rg.Count x = Application.CountIf(my_rg, my_rg.Cells(i)) If My_number >= my_rg.Count Then Exit Sub If x >= My_number Then dictionary.Add my_rg.Cells(i).Value, 1 End If Next Sheets(1).Range("d2") = dictionary.Count Sheets(1).Range("b2").Resize(dictionary.Count).Value = _ Application.Transpose(dictionary.keys) For m = 1 To dictionary.Count ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2)) Next Application.ScreenUpdating = True End Sub

جرب هذا الماكرو Sub TekrarList() Application.ScreenUpdating = False Dim x As Long Dim dictionary As Object Dim my_rg As Range Set dictionary = CreateObject("scripting.dictionary") Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown)) ActiveSheet.Range("b:d").ClearContents Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة" On Error Resume Next For i = 1 To my_rg.Count x = Application.CountIf(my_rg, my_rg.Cells(i)) If x >= 10 Then dictionary.Add my_rg.Cells(i).Value, 1 End If Next Sheets(1).Range("d2") = dictionary.Count Sheets(1).Range("b2").Resize(dictionary.Count).Value = _ Application.Transpose(dictionary.keys) For m = 1 To dictionary.Count ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2)) Next Application.ScreenUpdating = True End Sub

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

جرب هذا الملف TEKRAR COUNT.rar

الحل على الصفحة 4 الاصناف Salim.rar

تم معالجة الامر Book1salim.rar

حمل جزءا صغيراً منه حوالي 50 اسم لمعرفة المحتويات و كيفية التعامل

ارفع نموذجاً عن الملف

جرب هذا الملف تم حماية المعادلات لعدم العبث بها عن طريق الخطأ اظهار مسحوبات العملاء Salim.rar

جب هذا الملف كنموذح takrib.rar

جرب هذا الملف العامود الاصفر هو المعني بالامر format_as_you_like.rar

جرب هذا الملف ا salimحتساب الضريبه.rar

اكتب هذه المعادلة في A2 و اسحب نزولاً =IF(C2="","",MAX($A$1:A1)+1) يمنكنك استعمال هذا الماكرو Sub colorize() r = 2: t = 1 1: Do Until Cells(r, 2) = "" If Cells(r, 2).Interior.ColorIndex = 6 Then t = 1 If Cells(r, 3) = "" Then r = r + 1 GoTo 1 End If Cells(r, 1) = t r = r + 1 t = t + 1 Loop End Sub لاحظ المرفق ترقيم تلقائي مع شرط salim.rar

جرب هذه المعادلة =IF(C5="","",COUNTIF($C$5:C5,C5)+VLOOKUP(C5,{"سند قبض",0;"سند قيد",500;"سند صرف",1500},2,0)) تفضل الملف جاهز ترقيم salim.rar

جرب هذه المعادلة =IF(C5="","",COUNTIF($C$5:C5,C5)+VLOOKUP(C5,{"سند قبض",0;"سند قيد",500;"سند صرف",1500},2,0))

اكتب هذه المعادلة في A2 و اسحب نزولاً =IF(C2="","",MAX($A$1:A1)+1)

بعد إذن أخي ياسر نفس الشيء لكن بالمعادلات صباح الخير أخي ياسر انا لا ارى ان هناك لزوماً للمصفوفات يكفي هذا الكود Sub Tajmi3() lr = Application.Max(Range("a:a")) + 2 Range("b3:b" & lr).SpecialCells(xlCellTypeConstants).Copy Range("j3") Range("c3:c" & lr).SpecialCells(xlCellTypeConstants).Copy Range("k3") Range("e3:e" & lr).SpecialCells(xlCellTypeConstants).Copy Range("m3") Range("f3:f" & lr).SpecialCells(xlCellTypeConstants).Copy Range("n3") End Sub

استعمل هذه المعادلة =ABS(B3-C3) المعادلة التالية في الخلية D11 تستعمل معها Ctl+Shift+Enter و ليس Enter وحدها =SUM(ABS(D3:D10))

استعمل هذه المعادلة =ABS(B3-C3)

بعد إذن أخي ياسر نفس الشيء لكن بالمعادلات تجميع بالترتيب Salim.rar

في الخلية J3 اكتب هذه المعادلة و اسحب نزولاً =MOD(D3+H3-F3,1000) في الخلية k3 اكتب هذه المعادلة و اسحب نزولاً =(E3+I3-I3)+QUOTIENT(D3+H3-F3,1000)

جرب هذا الملف ABCD.rar

تستطيع من داخل الكود تغيير عدد اللجان من خلال المتغير K والرقم 19 ايضاُ استبدله بأي رقم تريد

جرب هذا الملف فقط اضغط على الزر ملء الكشوف توزيع اللجان بالمعادلات salim.rar

جرب هذا الكود Sub extract_num() Dim n, lr, x, r As Integer Dim s As String s = "" x = 4 r = 5 n = 6 lr = Cells(Rows.Count, 1).End(3).Row Do Until n > lr s = s & Cells(n, 1) & ";" n = n + 1 x = x + 1 If x Mod 15 = 0 Then r = r + 1: s = Cells(n - 1, 1) & ";": x = 5 Cells(r, 3) = s Loop End Sub