سليم حاصبيا

انظر الى الصورة وقل اين الخطأ ام لعلك تربد هذه النتيجة (في الملف المرفق) Naser_Masry_1.xlsx

حرب هذا الملف لا ضرورة لادراج اكثر من 700 صف لان المكرو الذي يعمل على صف واجد يستطيع العمل على الألوف منها يكفي ادراج نموذح بسيط لما تريد (50 صف كحد أقصى) كما اني لم أفهم ما هي الحاجة الى اليوزر فورم؟؟؟ Option Explicit Sub Get_data() Dim H As Worksheet Dim T As Worksheet Dim LrH%, LrT%, i%, Sd#, _ k%, Se#, My_val#, n% Dim Date1 As Date, Date2 As Date Dim M_date As Date, X_date As Date Dim Fr As Range, Wat As Range, Ro1%, Ro2% Dim x As Boolean, y As Boolean Set H = Sheets("Haraka") Set T = Sheets("Takrir") LrH = H.Cells(Rows.Count, 1).End(3).Row LrT = 20 T.Range("D5").Resize(LrT, 3).ClearContents Date1 = Application.Min(H.Range("C4:C" & LrH)) Date2 = Application.Max(H.Range("C4:C" & LrH)) If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Please Type Dates in D2 and E2" Exit Sub End If M_date = T.Range("D2"): X_date = T.Range("E2") If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Wrong Dates" Exit Sub End If T.Range("D2") = Application.Min(M_date, X_date) T.Range("E2") = Application.Max(M_date, X_date) M_date = T.Range("D2"): X_date = T.Range("E2") Set Wat = H.Range("A3:A" & LrH) For i = 5 To LrT Set Fr = Wat.Find(T.Range("B" & i), lookat:=1) If Fr Is Nothing Then GoTo Again Ro1 = Fr.Row: Ro2 = Ro1 Do x = H.Range("C" & Ro2) >= M_date y = H.Range("C" & Ro2) <= X_date If x And y Then Sd = Sd + Val(H.Range("D" & Ro2)) Se = Se + Val(H.Range("E" & Ro2)) n = n + 1 End If Set Fr = Wat.FindNext(Fr) Ro2 = Fr.Row If Ro2 = Ro1 Then Exit Do Loop T.Range("D" & i) = IIf(Sd = 0, "", Sd) T.Range("E" & i) = IIf(Se = 0, "", Se) My_val = Val(T.Range("C" & i)) + Val(T.Range("D" & i)) _ - Val(T.Range("E" & i)) T.Range("F" & i) = IIf(My_val = 0, "", My_val) T.Range("G" & i) = IIf(n = 0, "", n) Again: Sd = 0: Se = 0: n = 0 Next i End Sub T_Mansour.xlsm

نموذج عما تريده Naser_Masry.xlsx

لا أعرف ما المشكلة عندك (ربما اصدار الااوفيس قديم) عندي يعمل بشكل جيد (الصورة)

اذا كان ما فهمته صحيحاً هذا الكود (فقط اضغط الزر Run) Option Explicit Sub Creezy_sort() Dim CoL As Object Dim Lr%, i%, x% Dim arr Dim Ws As Worksheet Set Ws = Sheets("EN") With Ws .Range("E1").CurrentRegion.Offset(1).ClearContents Set CoL = CreateObject("System.Collections.sortedlist") Lr = .Cells(Rows.Count, 1).End(3).Row For i = 2 To Lr CoL.Add Len(.Cells(i, 1)) + i / 1000, .Cells(i, 1) & _ "*" & .Cells(i, 2) Next i x = 2 For i = 0 To CoL.Count - 1 .Cells(x, "E") = Split(CoL.GetByIndex(i), "*")(0) .Cells(x, "F") = Split(CoL.GetByIndex(i), "*")(1) arr = Split(Split(CoL.GetByIndex(i), "*")(1), ",") .Cells(x, "G") = UBound(arr) + 1 x = x + 1 Next End With Set Ws = Nothing: Set CoL = Nothing End Sub الملف مرفق Hitari.xlsm

بعد اذن الاستاذ إبراهيم هذا الكود Option Explicit Sub My_Repport() Dim Mh As Range, Single_Cel As Range Dim Y%, M%, i%, x% Dim My_Months(), Arr_Year() x = 6 Takrir.Range("A5").CurrentRegion.Offset(1).ClearContents Arr_Year = Array(2020, 2021, 2022, 2023, 2024, 2025) My_Months = Array("يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") If IsError(Application.Match( _ Takrir.Range("B3"), Arr_Year, 0)) Then Exit Sub If IsError(Application.Match( _ Takrir.Range("A3"), My_Months, 0)) Then Exit Sub Set Mh = Mahmoud.Range("A5").CurrentRegion.Columns(2) Y = Takrir.Range("B3") M = Application.Match(Takrir.Range("A3"), My_Months, 0) For Each Single_Cel In Mh.Cells If IsDate(Single_Cel) And Month(Single_Cel) = M _ And Year(Single_Cel) = Y Then Takrir.Range("A" & x).Resize(, 5).Value = _ Single_Cel.Offset(, -1).Resize(, 5).Value x = x + 1 End If Next Single_Cel End Sub الملف مرفق Naser_data.xlsm

Try This File Jalal.xlsx

استعمل هذا الكود البسيط Private Sub UserForm_Initialize() Me.OptionButton1 = False Me.OptionButton2 = False End Sub

فقط تغيير المعطيات Option Explicit '++++++++++++++++++++++++++++++ Dim Ra As Range, Rb As Range Dim a%, b%, i%, Bol As Boolean Dim m%, t% Dim Ky Dim S As Worksheet Dim Dic_Unique As Object Dim Dic As Object '++++++++++++++++++++++++++++++++++++++ Sub Item_Unique() Set S = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Set Dic_Unique = CreateObject("Scripting.Dictionary") a = S.Cells(Rows.Count, 1).End(3).Row b = S.Cells(Rows.Count, 2).End(3).Row Set Ra = S.Range("A2:A" & a) Set Rb = Range("B2:B" & b) For i = 2 To b Dic_Unique(S.Cells(i, 2).Value) = "" Next End Sub '""""""""""""""""""""""""""""""""""""""""""" Sub ExtractB() Item_Unique S.Range("K2").CurrentRegion.Offset(1).ClearContents If Dic_Unique.Count Then For Each Ky In Dic_Unique.keys Bol = IsError(Application.Match(Ky, Ra, 0)) If Bol Then Dic(Ky) = 1 Else Dic(Ky) = Application.CountIf(Rb, Ky) - 1 End If Next Ky End If If Dic.Count Then m = 2 For Each Ky In Dic.keys If Dic(Ky) <> 0 Then S.Range("K" & m).Resize(Dic(Ky)) = Ky m = m + Dic(Ky) End If Next t = S.Range("k2").CurrentRegion.Rows.Count If t > 1 Then S.Range("L2") = t - 1 S.Range("J2").Resize(t - 1).Value = _ Evaluate("Row(1:" & t - 1 & ")") End If End If Set S = Nothing Set Ra = Nothing: Set Rb = Nothing Set Dic_Unique = Nothing Set Dic = Nothing End Sub الملف مرفق Alla_20_4.xlsm

استبدل الرقم 1 بالرقم 2 في هذا السطر من الكود bol = Me.OptionButton1 = True

<رب هذا الملف Sub each_row_to_Its_sheet() Dim lr, i, x Dim sh As Worksheet Sheets("jan").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Feb").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Mar").Range("a2").CurrentRegion.Offset(1).ClearContents With Sheets("Legal") lr = .Cells(Rows.Count, 1).End(3).Row For i = 3 To lr If Not IsDate(.Cells(i, 2)) Then GoTo next_i Select Case Month(.Cells(i, 2)) Case 1: Set sh = Sheets("jan") Case 2: Set sh = Sheets("Feb") Case 3: Set sh = Sheets("Mar") Case Else: GoTo next_i End Select x = sh.Cells(Rows.Count, 1).End(3).Row + 1 sh.Cells(x, 1).Resize(, 5).Value = _ .Cells(i, 1).Resize(, 5).Value next_i: Next i End With End Sub الملف مرفق Naser.xlsm

الكود المطلوب Private Sub TextBox27_Change() Dim bol As Boolean If TextBox27.Value <> "" Then ListBox1.Visible = True Else ListBox1.Visible = False End If Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For i = 1 To 26 Controls("TextBox" & i).Text = "" Next i If TextBox27 = "" Then Exit Sub bol = Me.OptionButton1 = True If bol Then For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x Else For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like "*" & TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x End If End Sub الملف مرفق Allaq_User.xlsm

التعديل على الكود كما تريد Option Explicit '++++++++++++++++++++++++++++++ Dim Ra As Range, Rb As Range Dim a%, b%, i%, Bol As Boolean Dim m%, t% Dim Ky Dim S As Worksheet Dim Dic_Unique As Object Dim Dic As Object '++++++++++++++++++++++++++++++++++++++ Sub Unique_item() Set S = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Set Dic_Unique = CreateObject("Scripting.Dictionary") a = S.Cells(Rows.Count, 1).End(3).Row b = S.Cells(Rows.Count, 2).End(3).Row Set Ra = S.Range("A2:A" & a) Set Rb = Range("B2:B" & b) For i = 2 To a Dic_Unique(S.Cells(i, 1).Value) = "" Next End Sub '""""""""""""""""""""""""""""""""""""""""""" Sub Extract() Unique_item S.Range("D2").CurrentRegion.Offset(1).ClearContents If Dic_Unique.Count Then For Each Ky In Dic_Unique.keys Bol = IsError(Application.Match(Ky, Rb, 0)) If Bol Then Dic(Ky) = 1 Else Dic(Ky) = Application.CountIf(Ra, Ky) - 1 End If Next Ky End If If Dic.Count Then m = 2 For Each Ky In Dic.keys If Dic(Ky) <> 0 Then S.Range("E" & m).Resize(Dic(Ky)) = Ky m = m + Dic(Ky) End If Next t = S.Range("D2").CurrentRegion.Rows.Count If t > 1 Then S.Range("F2") = t - 1 S.Range("D2").Resize(t - 1).Value = _ Evaluate("Row(1:" & t - 1 & ")") End If End If Set S = Nothing Set Ra = Nothing: Set Rb = Nothing Set Dic_Unique = Nothing Set Dic = Nothing End Sub الملف من جديد Alla_20_3.xlsm

في هذه الحالة الماكرو هو الحل Option Explicit Sub In_A_But_Not_B() Dim Ra As Range, Rb As Range, _ a%, b%, i%, Bol As Boolean Dim Dic As Object With Sheets("Salim") .Range("D2").CurrentRegion.Offset(1).ClearContents a = .Cells(Rows.Count, 1).End(3).Row b = .Cells(Rows.Count, 2).End(3).Row If a < 2 Or b < 2 Then Exit Sub Set Ra = .Range("A2:A" & a) Set Rb = Range("B2:B" & b) Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To a Bol = IsError(Application.Match(.Cells(i, 1), Rb, 0)) If Bol Then Dic(Dic.Count + 1) = .Cells(i, 1).Value End If Next If Dic.Count Then .Range("E2").Resize(Dic.Count) = _ Application.Transpose(Dic.items) .Range("D2").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) .Range("f2") = Dic.Count End If End With End Sub الملف مرفق Alla_20_2.xlsm

تم التعديل (الصفخة Salim) Alla_20_1.xlsx