سليم حاصبيا

انظر الى الصورة وقل اين الخطأ ام لعلك تربد هذه النتيجة (في الملف المرفق) 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

ربما كان المطلوب Alla_20.xlsx

جرب هذا الملف الكود Option Explicit Function Elctric(Sm, n1, n2, n3, n4, n5, n6, n7) Dim x# If Sm <= 0 Then Elctric = 9 Exit Function End If Select Case Sm Case Is < 50: x = (50 - Sm) * n1 Case Is < 100: x = 50 * n1 + (Sm - 50) * n2 Case Is < 200: x = 50 * n1 + 50 * n2 + (Sm - 100) * n3 Case Is < 350: x = 50 * n1 + 50 * n2 + 100 * n3 + _ (Sm - 200) * n4 Case Is < 650: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + (Sm - 350) * n5 Case Is < 1000: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + (Sm - 650) * n6 Case Else: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + 650 * n6 + (Sm - 1000) * n7 End Select Elctric = x End Function الملف مرفق Electric.xlsm

لو كان الكود يعمل على الدوبل كليك لكان عنوانه Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) وليس Worksheet_Change(ByVal Target As Range)

الكودين من نوع Worksheet_Change(ByVal Target As Range) فأين الدويل كليك

انهما يعملان مع بعض

ربما هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Large_RG As Range Dim Unique_RG As Range Dim Empty_String$, Other__String$ Dim Option_string$ Dim Position% Const m = 2 Empty_String = "": Other__String$ = "Hirassa" Set Large_RG = Range("Q9:Y300") Set Unique_RG = Range("G3") Dim q%, r%, S%, t%, u%, v%, W%, x%, y% q = 17: r = 18: S = 19: t = 20 u = 21: v = 22: W = 23: x = 24: y = 25 Application.EnableEvents = False If Not Intersect(Target, Unique_RG) Is Nothing _ And Target.Cells.Count = 1 Then Range("D8") = Other__String End If If Not Intersect(Target, Large_RG) Is Nothing _ And Target.Cells.Count = 1 Then Select Case Target.Column Case q: Option_string = Empty_String: Position = q - 2 * m Case r: Option_string = Empty_String: Position = r - 3 * m Case S: Option_string = Empty_String: Position = S - 4 * m Case t: Option_string = Empty_String: Position = t - 5 * m Case u: Option_string = Empty_String: Position = u - 6 * m Case v: Option_string = Empty_String: Position = v - 7 * m Case W: Option_string = Empty_String: Position = W - 8 * m Case x: Option_string = Empty_String: Position = x - 9 * m Case y: Option_string = Empty_String: Position = y - 10 * m End Select If Target = "a" Then Target.Offset(, Position) = Empty_String End If End If Application.EnableEvents = True End Sub الملف Joe_code.xlsm

جرب هذا الملف Data_Val_Jo.xlsm

تم التعذيل على الماكروات Option Explicit Private sh As Worksheet Private Ro%, Col%, i% Private Arr_text(), Arr_Num() Private F As Range, itm, K% '++++++++++++++++++++++++++++++++++ Private Sub Fnd_change() Debut Dim R1%, R2% Me.ListBox1.RowSource = "" If Fnd = "" Then Exit Sub For Each itm In Arr_text Me.Controls(itm) = "" Next Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd & "*", Lookat:=2) If Not F Is Nothing Then R1 = F.Row: R2 = R1 Do With Me.ListBox1 .AddItem For i = 0 To .ColumnCount - 1 .List(.ListCount - 1, i) = sh.Cells(R2, 1).Offset(, i) Next Set F = sh.Range("A1:A" & Ro).FindNext(F) R2 = F.Row If R2 = R1 Then Exit Do End With Loop End If End Sub '+++++++++++++++++++++++++++++++ Private Sub ListBox1_Click() Debut Dim t% If ListBox1.ListCount = 0 Then Exit Sub If ListBox1.ListIndex = -1 Then Exit Sub t = Me.ListBox1.ListIndex Set F = sh.Range("A1:A" & Ro).Find(Me.ListBox1.List(t, 0), Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then For i = 0 To 6 Me.Controls(Arr_text(i)).Text = _ sh.Cells(K, Arr_Num(i)) Next End If End Sub '+++++++++++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Main") Ro = sh.Cells(Rows.Count, 1).End(3).Row Col = 7 Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _ "Qty", "Price", "Total") Arr_Num = Array(1, 2, 3, 4, 5, 6, 7) sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_del_Click() Debut Dim t%, st If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub t = Me.ListBox1.ListIndex st = Me.ListBox1.List(t, 0) Set F = sh.Range("A1:A" & Ro).Find(st, Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then sh.Cells(K, 1).Resize(, 7).Delete Me.ListBox1.RemoveItem (t) ListBox1.ListIndex = -1 For i = 0 To 6 Me.Controls(Arr_text(i)) = "" Next MsgBox "the Item " & """" & st & """" & Chr(10) & _ "with address " & """" & sh.Cells(K, 1).Resize(, 7).Address(0, 0) _ & """" & " Is Deleted", 64 Fnd = "" End If End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Debut Me.ListBox1.RowSource = _ sh.Range("A2").Resize(Ro, Col).Address End Sub الملف من جديد My_ListBox_1.xlsm

وهذا ما يحصل اكتب الرقم واضغط انتر وتظهر النتائج في التكست بوكس وليس في الليست بوكس

نتائج ماذا وبحث ماذا ???? كل الذي عندك فاتورة واحدة (غير مكررة) في كل سطر من الورقة و عندما تبجث عنها تراها امامك في التكس بوكسات ويتلون الصف في الشيت (لا افهم هنا ما قيمة التكس بوكسات اذا كنت نريد النتائج في اللــ ListBox )