سليم حاصبيا

1-لم اجد ورقة اسمها النقدية في الملف 2- كما لم اجد اي صف فيه كلمة اجمالي ربما تريد هذا الماكرو الذي يضع لك اجمالي كل صفحة حسب التاريخ في كل ورقة (الخلية B2 ) Option Explicit Sub Get_Sum_By_Array() Dim Main As Worksheet Dim Sh As Worksheet Dim Start_Date As Date, Final_date As Date Dim Last_Row%, i%, m%, AL_Result# Dim arr() Set Main = Sheets("Salim") Start_Date = Main.Cells(2, 3) Final_date = Main.Cells(2, 4) For Each Sh In Sheets If Sh.Name <> Main.Name Then Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row For i = 5 To Last_Row If Sh.Cells(i, 1) >= Start_Date And _ Sh.Cells(i, 1) <= Final_date Then ReDim Preserve arr(m) arr(m) = _ Application.Sum(Sh.Cells(i, 1). _ Offset(, 4).Resize(, 5)) m = m + 1 End If Next i If m > 0 Then Sh.Cells(4, 2) = Application.Sum(arr) AL_Result = AL_Result + Application.Sum(arr) Else Sh.Cells(4, 2) = 0 AL_Result = AL_Result End If Erase arr: m = 0 End If Next Sh Main.Cells(2, 2) = AL_Result Set Main = Nothing: Set Sh = Nothing End Sub الملف من جديد Total_sum_New.xlsm

جرب هذا الكود Option Explicit Sub Get_sum() Dim Main As Worksheet Dim Sh As Worksheet Dim Start_Date As Date, Final_date As Date Dim Last_Row%, i% Dim AL_Result# Set Main = Sheets("Salim") Start_Date = Main.Cells(2, 3): Final_date = Main.Cells(2, 4) For Each Sh In Sheets If Sh.Name <> Main.Name Then Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row For i = 5 To Last_Row If Sh.Cells(i, 1) >= Start_Date And _ Sh.Cells(i, 1) <= Final_date Then AL_Result = AL_Result + _ Application.Sum(Sh.Cells(i, 1).Offset(, 4).Resize(, 5)) End If Next i End If Next Sh Main.Cells(2, 2) = AL_Result Set Main = Nothing: Set Sh = Nothing End Sub الملف مرفق Total_sum.xlsm

ليس من المعقول تتبع ماكرو ما على 30 صفحة رجاء ارفع ملفاً بسيطاُ (3 شيتات لا أكثر) لان الماكرو الذي ينفذ على شيت واحده يمكنه ان ينفذ على الوف الشيتات مع اخذ بعين الاعتبار ادراج بيانات و ليس جداول فارغة (مع الحفاظ على الجداول بأن لا تحتوي على خلايا مدمحة ولا تتداخل معها خلايا لا علاقة للجداول بها)

جرب هذا الكود Option Explicit Sub Colorize_Dupicates() Dim Sh As Worksheet, A As Worksheet Dim Rg As Range, cel As Range, _ Act_Rg As Range, F_rg As Range Dim Fadr$, Sadr$ Dim D As Object Dim i%, X%, y% Set Sh = ActiveSheet Set Rg = Sh.Range("a1").CurrentRegion.Columns(1).Cells X = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Range("C1:z" & X).Clear Set D = CreateObject("Scripting.Dictionary") Rg.Interior.ColorIndex = xlNone For Each A In Sheets A.Range("a1").CurrentRegion.Columns(1) _ .Interior.ColorIndex = xlNone A.Range("C1:z100").Clear Next For Each cel In Rg For Each A In Sheets If A.Name <> Sh.Name Then Set Act_Rg = A.Range("a1").CurrentRegion.Columns(1) X = A.Cells(Rows.Count, 1).End(3).Row Set F_rg = Act_Rg.Find(cel, lookat:=1) If F_rg Is Nothing Then GoTo Next_A cel.Interior.ColorIndex = 6 Fadr = F_rg.Address: Sadr = Fadr Do F_rg.Interior.ColorIndex = 6 D(A.Name & " :Row (" & F_rg.Row & ")") = vbNullString Set F_rg = Act_Rg.FindNext(F_rg) Sadr = F_rg.Address If Sadr = Fadr Then Exit Do Loop End If Next_A: Next A If D.Count > 0 Then With cel.Offset(, 2).Resize(, D.Count) .Value = D.keys .Borders.LineStyle = 1 .Interior.ColorIndex = 38 .InsertIndent 1 End With With cel.Offset(, 2 + D.Count) .Value = IIf(D.Count = 1, "1 Duplicate", D.Count & " Duplicates") .Borders.LineStyle = 1 .Interior.ColorIndex = 6 .InsertIndent 1 End With Else With cel.Offset(, 2) .Value = "No Duplicates" .Borders.LineStyle = 1 .Interior.Color = vbGreen .InsertIndent 1 End With End If D.RemoveAll Next cel End Sub الملف مرفق Count_Tekrars.xlsm

لغة الكيبورد الأجنبية (: جرف الكاف على الكيبورد) لادخال التاريح بشكل ثابت (:+Ctrl) لادخال االوقت بشكل ثابت ( :+Shift+Crrl )

حيث انكا لم ترفع ملفاً للمعاينة اقترح هذا الملف الذي يمكن تعديله كما تريد Working time.xlsx

أكثر من مرة أكرر انه لا يجوز ان يكون في جداول الاكسل خلايا مدمجة ويكون مستقلاً عن اي بيانات اخرى (ليس فقط في ازمة كورونا بل في كل الأحوال) تم ادراج صف فارغ لتحييد الجدول (الصف رقم 6) الماكرو Option Explicit Sub Filter_Class() If ActiveSheet.Name <> "Feuil1" Then Exit Sub Dim F As Worksheet Dim D1 As Object, D2 As Object, D3 As Object Dim i%, a As Boolean, b As Boolean, c As Boolean Dim x%, y%, m%, z%, arr, ky Dim st$ Set F = Sheets("Feuil1") Set D1 = CreateObject("Scripting.Dictionary") Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") With F .Range("P7").CurrentRegion.ClearContents .Range("Ad7").CurrentRegion.ClearContents .Range("P27").CurrentRegion.Offset(1).ClearContents i = 8 Do Until i = 39 st = Mid(Trim(.Cells(i, 2)), 1, 1) Select Case st Case "3": a = True: b = False: c = False Case "2": b = True: a = False: c = False Case Else: b = False: a = False: c = True End Select arr = Application.Transpose(.Cells(i, 2).Resize(, 13)) arr = Application.Transpose(arr) If a Then D3(z) = Join(arr, "*"): z = z + 1 ElseIf b Then D2(y) = Join(arr, "*"): y = y + 1 Else D1(x) = Join(arr, "*"): x = x + 1 End If i = i + 1 Loop m = 7 If D3.Count Then For Each ky In D3 .Cells(m, "P").Resize(, 13) = Split(D3(ky), "*") m = m + 1 Next ky End If m = 7 If D2.Count Then For Each ky In D2 .Cells(m, "AD").Resize(, 13) = Split(D2(ky), "*") m = m + 1 Next ky End If m = 27 If D1.Count Then For Each ky In D1 .Cells(m, "P").Resize(, 13) = Split(D1(ky), "*") m = m + 1 Next ky End If .Range("P7").CurrentRegion.Value = _ .Range("P7").CurrentRegion.Value .Range("Ad7").CurrentRegion.Value = _ .Range("Ad7").CurrentRegion.Value .Range("P27").CurrentRegion.Value = _ .Range("P27").CurrentRegion.Value End With End Sub الملف مرفق Te3dad.xlsm

صدقني لم أفهم شيئاً

شاهد هذا الفيديو https://www.youtube.com/watch?v=hElkHVLg7a4

بعد اذن اخي ابراهيم هذا الكود (من سطر واحد) وبدون حلقات تكرارية Sub test() On Error Resume Next Range("A2", Range("A1"). _ End(4)).Offset(, 1). _ SpecialCells(4).Value = "Abscent" End Sub

لست بحاجة الى كود لتنفيذ هذا العمل شاهذ المرفق My_ ITEM 1111.xlsm

الكثير منّا يحاول ادخال التاريخ في الكومبوبوكس لكن المشكلة انه يظهر بالتنسيق الأميركي (شهر /يوم /سنة) بحلية بسيطة يمكننا ان نخدع الاكسل لأدخال التاريخ في الكومبوبوكس كما نريد نحن (يوم/شهر/ سنه) اذ ليس الامر باختياره انظر الى الملف المرفق لتعرف ماذا اعني Reel_date_to Combo.xlsm

اعنقد هذا الماكرو يقوم بما تريد Sub Salim_sum() Dim Ary As Variant Dim Dic As Object Dim i%, x%, Ro%, k Dim itm If Sheets("ALL").Range("A1"). _ CurrentRegion.Rows.Count > 1 Then _ Sheets("ALL").Range("A2"). _ CurrentRegion.Offset(1).ClearContents Set Dic = CreateObject("scripting.dictionary") Ary = Array("Plus_1", "Plus_2", "Minus_1", "Minus_2", "Plus_5") For Each itm In Ary x = IIf(Sheets(itm).Name Like "P*", 1, -1) Ro = Sheets(itm).Range("a1").CurrentRegion.Columns(1).Rows.Count For i = 2 To Ro k = IIf(IsNumeric(Sheets(itm).Range("D" & i)), _ Sheets(itm).Range("D" & i), 0) If Not Dic.Exists(Sheets(itm).Range("A" & i).Value) Then Dic(Sheets(itm).Range("A" & i).Value) = x * (k) Else Dic(Sheets(itm).Range("A" & i).Value) = _ Dic(Sheets(itm).Range("A" & i).Value) + x * (k) End If Next i Next itm Sheets("ALL").Range("A2").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) Sheets("ALL").Range("D2").Resize(Dic.Count) = _ Application.Transpose(Dic.Items) Set Dic = Nothing: Set Cl = Nothing: Erase Ary End Sub الملف مرفق _My_sum.xlsm

بعد أي تعديل تقوم به في البيانات اضغط الزر و الماكرو يقوم بتحديث كل شيء (ولا حاجة للمعادلات)

عندي يعمل بشكل طبيعي (عدّ ل على الماكرو كما تريد لاني لا أعرف بالضبط ما المقصود منه) _users And sheets.xlsm

ممكن ان يكون المطلوب Option Explicit Sub Join_data_NEW() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim i%, Dic As Object, k, my_key, ARR Set Dic = CreateObject("Scripting.Dictionary") Cells(3, "H").CurrentRegion.Clear Cells(3, "AA").CurrentRegion.Clear i = 3 Do Until Cells(i, "E") = vbNullString k = Cells(i, "F") If Not Dic.Exists(Cells(i, "E").Value) Then Dic(Cells(i, "E").Value) = k Else Dic(Cells(i, "E").Value) = Dic(Cells(i, "E").Value) & "," & k End If i = i + 1 Loop Cells(3, "H").Resize(Dic.Count) = Application.Transpose(Dic.keys) i = 3 For Each my_key In Dic.keys Cells(i, "I") = Dic(my_key) & "." i = i + 1 Next my_key i = 3 '+++++++++++++++++++++++++++ Cells(3, "AA").Resize(Dic.Count) = Application.Transpose(Dic.keys) For Each my_key In Dic.keys ARR = Split(Dic(my_key), ",") Cells(i, "AB").Resize(, UBound(ARR) + 1) = ARR i = i + 1 Next my_key '+++++++++++++++++++++++++++ Set Dic = Nothing With Cells(3, "H").CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True End With Cells(3, "H").CurrentRegion.Columns(1) _ .Interior.ColorIndex = 38 With Cells(3, "AA").CurrentRegion.SpecialCells(2) .Interior.ColorIndex = 28 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True End With Cells(3, "AA").CurrentRegion.Columns(1) _ .Interior.ColorIndex = 38 End Sub الملف مرفق للمعاينة talabia_SL _Plus.xlsm

تصحيح الكود Sub sumsub() Dim Ary As Variant Dim Dic As Object Dim i% Dim Cl As Range Dim M Set Dic = CreateObject("scripting.dictionary") Ary = Array("sheet1", "sheet2", "Sheet5", "sheet3", "sheet4") With Sheets("Sheet6") For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(3)) Dic.Item(Cl.Value) = Cl.Offset(, 3).Value Next Cl End With For i = 0 To UBound(Ary) - 1 With Sheets(Ary(i)) For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(3)) If Dic.Exists(Cl.Value) Then M = Dic.Exists(Cl.Value) M = IIf(i < 3, M + Cl.Offset(, 3), _ M - Cl.Offset(, 3)) Dic(Cl.Value) = M End If Next Cl End With Next i Sheets("Sheet6").Range("D2").Resize(Dic.Count).Value = _ Application.Transpose(Dic.items) Set Dic = Nothing: Set Cl = Nothing: Erase Ary End Sub

تفضل EXTRA_FOUND (2).xlsm

هذا الأنك تقوم بالترتيب على كل الاعمدة من A الى G لذلك يجب ان تقوم بالتصفية في العامود A فقط

الملف الدي ارسلته لك يعمل هذا الشيء و يضع النتيحة في الاعمدة M,N,O

الكود في Vba لا يتعامل مع التنسيق الشرطي لانه يأخذ اللون الحقيقي للخلية وليس لونها من خلال التنسيق الشرطي لفهم ما تريد ارجو ادراج جدول بسيط بالنتائج المتوقعة(يدوياً) مع اختصار البيانات الى 7 او 10 صفوف لا أكثر (كي يمكن تتبع عمل الكود) لا ضرورة لكتابة اسماء طويلة يمكن استعمال الأحرف مثالاً A3 A2 A1 .... و ذلك لسرعة مقارنة النتائج

السؤال مبهم بعض الشيء 1- هل تريد ما موجود في العامود الاول وليس في الثاني؟؟ 2-هل تريد ما موجود في العامود الثاني وليس في الاول؟؟ 3-هل تريد المشترك بين العامودين؟؟ تم استخراج الفيم بواسطة المعادلات في الأعمدة من I الى K (الاعمدة مخفية لحسن الرؤية) لكن ليست مرتبة أبجدياً على كل خال جرب هذا الماكرو يقوم بترتيب النتائج ابجدياً في الاعمدة من M الى O Option Explicit Sub Exract_Common_Values() Rem This Macro Extract The common Of two Columns by Order Rem Created By Salim Hasbaya on 8/4/2020 If ActiveSheet.Name <> "Salim" Then GoTo Leave_Me_Please Application.ScreenUpdating = False Dim st, I% If Range("M1").CurrentRegion.Rows.Count > 1 Then _ Range("M1").CurrentRegion.Offset(1).Clear st = "SUM(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,1,0))" st = Evaluate(st) For I = 2 To st + 1 Range("M" & I).FormulaArray = _ "=INDEX(E$2:E$44,SMALL(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,ROW($E$2:$E$44)-ROW($E$2)+1),ROWS($A$1:A" & I - 1 & ")))" Range("N" & I).FormulaArray = _ "=INDEX(F$2:F$44,SMALL(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,ROW($E$2:$E$44)-ROW($E$2)+1),ROWS($A$1:A" & I - 1 & ")))" Range("O" & I).FormulaArray = _ "=INDEX(G$2:G$44,SMALL(IF(COUNTIF($A$2:$A$44,$E$2:$E$44)+COUNTIF($E$2:$E$44,$A$2:$A$44)=2,ROW($E$2:$E$44)-ROW($E$2)+1),ROWS($A$1:A" & I - 1 & ")))" Next With Range("m1").CurrentRegion .Value = .Value .Sort KEY1:=.Cells(1, 1), Header:=1 If .Rows.Count > 1 Then With .Offset(1).Resize(.Rows.Count - 1) .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 With .Font .Size = 14: .Bold = True End With .Columns.AutoFit End With End If End With Leave_Me_Please: Application.ScreenUpdating = True End Sub الملف مرفق EXTRA_FOUND.xlsm

بعد اذن اخي الرائد هذا الماكرو Option Explicit Sub Join_data() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim i%, Dic As Object, k, my_key Set Dic = CreateObject("Scripting.Dictionary") Cells(3, "H").CurrentRegion.Clear i = 3 Do Until Cells(i, "E") = vbNullString k = Cells(i, "F") If Not Dic.Exists(Cells(i, "E").Value) Then Dic(Cells(i, "E").Value) = k Else Dic(Cells(i, "E").Value) = Dic(Cells(i, "E").Value) & "," & k End If i = i + 1 Loop Cells(3, "H").Resize(Dic.Count) = Application.Transpose(Dic.keys) i = 3 For Each my_key In Dic.keys Cells(i, "I") = Dic(my_key) & "." i = i + 1 Next my_key Set Dic = Nothing With Cells(3, "H").CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 End With End Sub الملف للمعاينة مرفق talabia_SL.xlsm

اعتذر اذ ليس لدي الوقت لعمل هكذا فيديو (ربما يقوم احد الاساتذة بالمساعدة لعمل هذا) لذا اقترح : 1-مسح كل الصفحات ما عدا الصفحة Main 2-بعد ذلك يمكن تتبع خطوات الماكرو خطوة خطوة لمعرفة كيفية عمله

تغيير اسم الصفحة الاولى الى Main لسهولة نسخ الكود ولصقه الكود Option Explicit Sub Salim_code() Application.ScreenUpdating = False Dim Filt_Rg As Range Dim M As Worksheet Dim Sh As Worksheet Dim i% Set M = Sheets("Main") Set Filt_Rg = M.Range("B3").CurrentRegion If M.AutoFilterMode Then Filt_Rg.AutoFilter End If i = 4 Do Until M.Range("k" & i) = vbNullString If Not Application.Evaluate("ISREF('" & M.Range("k" & i) & "'!A1)") Then Sheets.Add(, M).Name = M.Range("k" & i) End If i = i + 1 Loop For Each Sh In Sheets If Sh.Name <> M.Name Then Sh.Range("B3").CurrentRegion.Clear Filt_Rg.AutoFilter 10, Sh.Name Filt_Rg.SpecialCells(12).Copy Sh.Range("B3") Sh.Range("B3").CurrentRegion.Columns.AutoFit End If Next M.Select If M.AutoFilterMode Then Filt_Rg.AutoFilter End If Application.ScreenUpdating = True End Sub الملف مرفق Sandouk_2020.xlsm