سليم حاصبيا

اخي العزيز حسين أرى انه لا ضرورة لحلقة تكرارية من ثاني صف في العامود C الى ان تجد ما نفتش عنه (ممكن ان يكون الرقم في الصف رقم 5000 مثلاً اذا كانت البيانات كثيرة) يكفي ان نستعمل دالة Find في VBA لايجاد الرقم بسرعة اكبر بكثير ، لان هذه الدالة تضع يدها على الصف المطلوب مباشرة باستعمال هذا الماكرو Sub Find_Me() Dim rng, r% On Error Resume Next With Sheets("Sheet1") .Range("H2") = vbNullString If .Range("G2") = "" Then End Set rng = .Range("c2", Range("c1").End(4)) r = rng.Find(.Range("G2"), lookat:=1).Row If r > 0 Then .Range("H2") = .Cells(r, "D") End With End Sub

جرب هذا الملف بالطبع بعد اذن الاخ حسين مأمون VL_FUNTION.xlsx

بالنسبة للمناديب جرب هذا الكود بشكل منفرد مبدياً (يمكن التعدل عليه اذا كان غير مناسب و من ثم اضافته الى الكود الاساسي) الزر Mandoub لم افهم عن اي اعدادالتي يجب جمعها تتكلم Option Explicit Sub man_doub() Dim LA_SALIM%, LG_data% Dim my_RgA As Range, my_RgG As Range Dim i%, k%, st$ LA_SALIM = Sheets("SALIM").Cells(Rows.Count, "A").End(3).Row LG_data = Sheets("data").Cells(Rows.Count, "G").End(3).Row Sheets("SALIM").Range("E3").Resize(1000).ClearContents If LA_SALIM = 2 Then Exit Sub If LG_data = 1 Then Exit Sub Sheets("data").Range("Al2").Resize(500).Formula = _ "=IF(H2="""","""",SUMPRODUCT(--(H2&G2=$H$2:$H2&$G$2:$G2)))" Set my_RgA = Sheets("SALIM").Range("a3:a" & LA_SALIM) Set my_RgG = Sheets("data").Range("G2:G" & LG_data) For i = 3 To LA_SALIM If Sheets("SALIM").Cells(i, 1) = vbNullString Then GoTo Next_i For k = 2 To LG_data If Sheets("data").Cells(k, "G") = vbNullString Then GoTo Next_K If Sheets("SALIM").Cells(i, 1) = Sheets("data").Cells(k, "G") _ And Sheets("data").Cells(k, "AL") = 1 Then st = st & Sheets("data").Cells(k, "H") & "+" End If Next_K: Next k If Len(st) > 0 Then Sheets("SALIM").Cells(i, 5) = _ Mid(st, 1, Len(st) - 1) End If st = "" Next_i: Next i Sheets("data").Range("AL2").Resize(500).ClearContents End Sub الملف مرفق Show Sales_salim_Mandob.xlsm

قم بادراج ورقة وتسميهتا Salim (أو قم بتسمية اي ورقة فارغة Salim) ثم نفذ هذا الكود (و ترى النتيجة في شيت Salim) Option Explicit Sub REMOVE_DUPL() Sheets("Salim").Range("a1").CurrentRegion.Clear Sheets("Feuil1").Range("a1").CurrentRegion.Copy _ Sheets("Salim").Range("a1") Sheets("Salim").Range("a3").CurrentRegion.RemoveDuplicates _ Columns:=Array(2, 6, 7, 8, 9, 10 _ , 11, 12, 13, 14, 15), Header:=1 Application.CutCopyMode = False End Sub الملف مرفق Classeur32_A.xlsm

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

ملاحظة اخيرة

تم معالجة الامر (سم المندوب) وهذه المرة بـــ معادلة بسيطة تم ادراجها في نفس الكود (ولا لزوم لتكرار التاريخ حيث ان البيانات بين تاريخ واخر بفصلها صف فارغ) الكود الجديد Option Explicit Sub Give_data1() Rem =====>>> Created By Salim Hasbaya On 1/9/2019 Dim Dict As Object Dim st, ff% Dim Ro%, x%, t%, arr Dim Itm, i%: i = 2 Dim K, Ky, xx% ': xx = 3 Dim SA As Worksheet: Set SA = Sheets("Salim") Dim DA As Worksheet: Set DA = Sheets("data") Dim My_col As New Collection Dim My_col2 As New Collection 'For remove the Contents Of the sheet "Salim" Please remove _ the "'" from the next line 'SA.Range("a3").Resize(10000, 5).ClearContents xx = SA.Cells(Rows.Count, "c").End(3).Row xx = IIf(xx = 2, 3, xx + 2) Set Dict = CreateObject("SCRIPTING.DICTIONARY") Ro = DA.Cells(Rows.Count, "G").End(3).Row For i = 2 To Ro On Error Resume Next My_col.Add CDate(DA.Range("G" & i).Value), CLng(DA.Range("G" & i).Value) & " " Next For i = 1 To My_col.Count For x = 2 To Ro If DA.Cells(x, "G") = My_col(i) Then K = DA.Cells(x, "L") Itm = Application.CountIf(DA.Range("E2:L" & x), DA.Range("L" & x)) If Not Dict.Exists(My_col(i)) And Itm = 1 Then Dict.Add My_col(i), K Else Dict(My_col(i)) = Dict(My_col(i)) & "," & K End If End If Next x SA.Range("A" & xx) = My_col(i) For Each Ky In Dict.keys arr = Split(Dict(Ky), ",") For ff = 0 To UBound(arr) On Error Resume Next My_col2.Add arr(ff), arr(ff) Next ff If My_col2(1) = "" Then My_col2.Remove (1) On Error GoTo 0 Erase arr ReDim arr(1 To My_col2.Count) For ff = 1 To My_col2.Count arr(ff) = My_col2(ff) Next ff t = UBound(arr) If t >= 1 Then SA.Cells(xx, 3).Resize(UBound(arr) - LBound(arr) + 1) = _ Application.Transpose(arr) End If xx = SA.Cells(Rows.Count, "c").End(3).Row + 2 Dict.RemoveAll: Erase arr: Set My_col2 = New Collection Next Ky Next 'For remove the Contents Of the sheet "Data" Please remove _ the "'" from the next line 'kiLL_data With SA.Range("d3").Resize(xx - 2) .Formula = "=IF(c3="""","""",INDEX(Data!$H$2:$H$500,MATCH($C3,Data!$L$2:$L$500,0)))" .Value = .Value End With Dict.RemoveAll: Erase arr: Set My_col2 = Nothing Set My_col = Nothing: Set SA = Nothing: Set DA = Nothing End Sub '++++++++++++++++++++++++++++++++++++++ Sub kiLL_data() Sheets("Data").Range("a2", Range("L1").End(4)).ClearContents End Sub الملف من جديد Show Sales_salim_ 2019_Super.xlsm

استبدل حرف الـــ E بحرف الـــ L في الماكرو

تم معالجة الامر Classeur02_Mawad_new 9.xlsx

تم التعديل على الماكرو (فقط للفنادق ) اما الباقي فيما بعد لضيق الوقت Option Explicit Sub Give_data1() Rem =====>>> Created By Salim Hasbaya On 1/9/2019 Dim Dict As Object Dim st, ff% Dim Ro%, x%, t%, arr Dim Itm, i%: i = 2 Dim K, Ky, xx% ': xx = 3 Dim SA As Worksheet: Set SA = Sheets("Salim") Dim DA As Worksheet: Set DA = Sheets("data") Dim My_col As New Collection Dim My_col2 As New Collection 'For remove the Contents Of the sheet "Salim" Please remove _ the "'" from the next line 'SA.Range("a3").Resize(10000, 5).ClearContents xx = SA.Cells(Rows.Count, "c").End(3).Row xx = IIf(xx = 2, 3, xx + 2) Set Dict = CreateObject("SCRIPTING.DICTIONARY") Ro = DA.Cells(Rows.Count, "G").End(3).Row For i = 2 To Ro On Error Resume Next My_col.Add CDate(DA.Range("G" & i).Value), CLng(DA.Range("G" & i).Value) & " " Next For i = 1 To My_col.Count For x = 2 To Ro If DA.Cells(x, "G") = My_col(i) Then K = DA.Cells(x, "L") Itm = Application.CountIf(DA.Range("L2:L" & x), DA.Range("L" & x)) If Not Dict.Exists(My_col(i)) And Itm = 1 Then Dict.Add My_col(i), K Else Dict(My_col(i)) = Dict(My_col(i)) & "," & K End If End If Next x SA.Range("A" & xx) = My_col(i) For Each Ky In Dict.keys arr = Split(Dict(Ky), ",") For ff = 0 To UBound(arr) On Error Resume Next My_col2.Add arr(ff), arr(ff) Next ff If My_col2(1) = "" Then My_col2.Remove (1) On Error GoTo 0 Erase arr ReDim arr(1 To My_col2.Count) For ff = 1 To My_col2.Count arr(ff) = My_col2(ff) Next ff t = UBound(arr) If t >= 1 Then SA.Cells(xx, 3).Resize(UBound(arr) - LBound(arr) + 1) = _ Application.Transpose(arr) End If xx = SA.Cells(Rows.Count, "c").End(3).Row + 2 Dict.RemoveAll: Erase arr: Set My_col2 = New Collection Next Ky Next 'For remove the Contents Of the sheet "Data" Please remove _ the "'" from the next line 'kiLL_data Dict.RemoveAll: Erase arr: Set My_col2 = Nothing Set My_col = Nothing: Set SA = Nothing: Set DA = Nothing End Sub '++++++++++++++++++++++++++++++++++++++ Sub kiLL_data() Sheets("Data").Range("a2", Range("L1").End(4)).ClearContents End Sub الملف مرفق Show Sales_salim_ 2019_new.xlsm

احذف هذا الاسطر من الكود ويكفي ان تضيف زر واحد قبل تنفيذ الماكرو ActiveWindow.ScrollColumn = 3 ActiveWindow.ScrollColumn = 2 ActiveWindow.ScrollColumn = 1 ActiveSheet.Buttons.Add(58.5, 86.25, 114.75, 35.25).Select Selection.OnAction = "البحث" Selection.Characters.Text = "البحث"

جرب هذا الكود Option Explicit Sub Give_data() Dim Dict As Object Dim Itm, i%: i = 2 Dim K, Ky, xx%: xx = 3 Dim SA As Worksheet: Set SA = Sheets("Salim") Dim DA As Worksheet: Set DA = Sheets("data") Set Dict = CreateObject("SCRIPTING.DICTIONARY") SA.Range("A2").CurrentRegion.Offset(1).ClearContents Do Until DA.Range("G" & i) = vbNullString K = DA.Range("G" & i): Itm = DA.Range("L" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) & "," & Itm End If i = i + 1 Loop SA.Range("A3").Resize(Dict.Count) = _ Application.Transpose(Dict.keys) For Each Ky In Dict.keys SA.Cells(xx, 3) = Join(Split(Dict(Ky), ","), ",") xx = xx + 1 Next Dict.RemoveAll: i = 2: xx = 3 Do Until DA.Range("G" & i) = vbNullString K = DA.Range("G" & i): Itm = DA.Range("H" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) & "," & Itm End If i = i + 1 Loop For Each Ky In Dict.keys SA.Cells(xx, 4) = Join(Split(Dict(Ky), ","), ",") xx = xx + 1 Next Dict.RemoveAll: Set Dict = Nothing End Sub الملف مرفق Show Sales_salim_ 2019.xlsm

جرب هذه المعادلة في الخلية B2 واسحب يساراً ثم نزولاً =IF(LEN($A2)-COLUMNS($A$1:A1)<=-1,"",MID($A2,LEN($A2)-COLUMNS($A$1:A1)+1,1)) الملف مرفق national_number.xlsx

تم معالجة الامر Classeur02_Mawad_new.xlsx

لعمل التسلسل هذه المعادلة في الخلية A4 واسحب نزولاً =IF(B4="","",MAX($A$3:A3)+1)

ممكن ان يكون المطلوب Classeur02_Mawad.xlsx

الصفحة Feiul3 من هذا الملف Classeur02_salim_new.xlsx

لا ليس هناك مشكلة اعادة الضغط على العلامة الخضراء لازالتها و من ثم وضعها في المكان المناسب

انت وضعت علامة صح على مشاركتك الخاصة (اي ان اجابتك هي الافضل دون مواخذة) يجب وضع العلامة في المشاركة التي ارسلتها لك (حيث الكود)

هنا

العامود الاصفر في صفحة Salim من هذا الملف No_dup _by_formula.xlsm

جرب هذا الملف Classeur02_salim.xlsx

ما تراه ليس الانذار السادس او اسابع مثلاُ : أنذار 5(1) معناه انذار الخمسة ايام رقم 1 أنذار 7(2) معناه انذار السبعة ايام رقم 2 وهكذا

اذا كان هذا المطلوب اضغط افضل اجابة لاغلاق الموضوع

هذا الكود يفي بالغرض ان شاء الله (تم تغيير اسماء الصفحات لنسخ الكود بشكل جيد وعدم الوقوع في مشاكل اللغة حيث تظهر حروف غير معروفة عند البعض) Option Explicit Sub AnyThing() Dim lastrow_1 As Long, counter As Long Dim lastrow_2 As Long, key As Variant Dim sh1 As Worksheet, sh2 As Worksheet Dim rng1, rng2 As Range, p As Variant Dim dict As Object Set sh1 = Sheets("SH1") Set sh2 = Sheets("SH2") sh2.Range("I3").Resize(1000, 3).ClearContents lastrow_1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row lastrow_2 = sh1.Cells(sh2.Rows.Count, "B").End(3).Row Set rng1 = sh1.Range("A3:D" & lastrow_1) Set rng2 = sh2.Range("A3:D" & lastrow_2) Set dict = CreateObject("Scripting.Dictionary") For Each p In rng1.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '=============================== For Each p In rng2.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '============================== counter = 2 With sh2 For Each key In dict.Keys counter = counter + 1 .Cells(counter, "I").Resize(1, 2) = Split(key, ",") .Cells(counter, "K") = dict(key) Next key End With dict.RemoveAll: Set dict = Nothing Set sh1 = Nothing: Set sh2 = Nothing Set rng1 = Nothing: Set rng2 = Nothing End Sub الملف المرفق Total.xlsm