محمد هشام.

اخي الكود يتم تنفيده تلقائيا عند تغيير القيمة في عمود من / إلى المدرسة بمجرد اختيار عبارة من المدرسة يتم نقل العمود الهدف الى ورقة (محولين الى المدرسة) دون الحاجة لاستخدام الازرار اما ادا كنت تريد تنفيده فقط عند الظغط على زر تحويل الطالب تفضل تم ربط الكود بالزر سجل مستجدين - 2025 V3.xlsm

الكود يشتغل عندي بشكل جيد !!!! اخي قم بغلق الملف وإعادة تشغيله مع محاول تنفيذ الكود مباشرة بعد إضافة عبارة من المدرسة على بعض الصفوف ووافينا بالنتيجة

أظن أن نظام القائمة أسهل!!!! هل تقصد أنك ترغب بكتابة الإسم وجلب البيانات باستخدام زر البحث؟ جرب هذا ReDim a(1 To UBound(r), 1 To UBound(r, 2)) For I = 1 To UBound(r) If r(I, 5) = clé Then F = F + 1 a(F, 1) = r(I, 2):a(F, 2) = r(I, 4): a(F, 3) = r(I, 6) a(F, 4) = r(I, 7):a(F, 5) = r(I, 3):a(F, 6) = r(I, 1) End If Next I Search_by_name-V2.xlsm

ادن جرب هدا Option Explicit Sub Filter_ListUniques() Dim lastRow&, n&, F& Dim WS As Worksheet, src As Worksheet, _ tmp As Range, rngCell As Range, c As Range, _ rng As Range, r As Range, list As Range Set WS = Worksheets("1"): Set src = Worksheets("التقرير") With Application .ScreenUpdating = False With WS If .AutoFilterMode Then .AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "H").End(xlUp).Row Set rng = WS.Range("A1:J" & lastRow) Intersect(src.Range(src.Rows(1), _ src.UsedRange.Rows(src.UsedRange.Rows.Count)), src.Range("A:J")).Clear .Range("H1:H" & lastRow).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=.Range("AA1"), Unique:=True Set list = .Range(.[AA2], .Cells(.Rows.Count, "AA").End(xlUp)) For Each tmp In list rng.AutoFilter 8, tmp.Value n = src.Range("A" & src.Rows.Count).End(xlUp).Row If n > 2 Then n = n + 2 rng.SpecialCells(xlCellTypeVisible).Copy src.Range("a" & _ n).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Next tmp WS.AutoFilterMode = False End With On Error Resume Next F = src.Range("A:J").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row Set rngCell = src.Range("A1 :J" & F) For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next For Each r In src.Range("A1:A" & F) If r.Value = "سعر الوقود" Then With src.Range(src.Cells(r.Row, 1), src.Cells(r.Row, 10)) .Interior.Color = RGB(51, 204, 204) .Font.Bold = True End With End If Next .CutCopyMode = False .ScreenUpdating = True End With End Sub تقرير 3.xlsm

تفضل جرب هدا ملاحظة لم يتم تحديد العمود الاخير لعدم معرفتي لاسم العمود المرغوب جلب بياناته لهدا سبق تدكيرك بارفاق عينة للنتائج المتوقعة Sub Search_by_name() Dim WS As Worksheet, src As Worksheet Dim r As Variant, a As Variant, Rng As Range Dim i As Long, F As Long, Lastrow As Long Dim clé As Variant, Search As Range Set WS = Worksheets("AA"): Set src = Worksheets("UU") Lastrow = WS.Columns("B:I").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set Rng = WS.Range("B2:I" & WS.Cells(Rows.Count, "F").End(xlUp).Row) r = Rng.Value2: clé = src.[C1] If clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "الامل الدولية": Exit Sub Set Search = WS.Range("F2:F" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " غير موجود", vbExclamation: Exit Sub Application.ScreenUpdating = False src.Range("B3:G" & src.Rows.Count).ClearContents ReDim a(1 To UBound(r), 1 To UBound(r, 2)) For i = 1 To UBound(r) If r(i, 5) = clé Then F = F + 1 a(F, 1) = r(i, 2) a(F, 2) = r(i, 4) a(F, 3) = r(i, 6) a(F, 4) = r(i, 7) a(F, 5) = r(i, 3) ' رقم اليوزر ' a(F, ؟) = r(i, ؟) End If Next i src.[B2].Offset(1).Resize(F, UBound(a, 2)).Value2 = a Application.ScreenUpdating = True End Sub وفي حدث ورقة (UU) Private Sub Worksheet_Activate() ' جلب الاسماء بدون تكرار Set WS = Worksheets("AA") Application.ScreenUpdating = False Set MonDico = CreateObject("Scripting.Dictionary") For Each cnt In WS.Range("f2", WS.[f65000].End(xlUp)) If cnt <> "" Then MonDico(cnt.Value) = "" Next cnt With WS.Range("L2:L65000") .ClearContents .Resize(MonDico.Count) = Application.Transpose(MonDico.Keys) End With Application.ScreenUpdating = True End Sub '===================== Private Sub Worksheet_Change(ByVal Target As Range) ' تنفيد الكود عند اختيار الاسم من القائمة المنسدلة Select Case Target.Address(0, 0) Case "C1": Call Search_by_name Target.Select Case Else: Exit Sub End Select End Sub الخلية C1 ورقة (UU) ضع الصيغة التالية =OFFSET(AA!$L$2, 0, 0, COUNTA(AA!$L:$L), 1) بالتوفيق......... Search_by_name.xlsm

قم بتغيير داخل الكود الخاص بجلب البيانات مباشرة دون ان تنسى مراجعة هده الاكواد او حدفها عند التوصل للنتائج المطلوبة

اخي ما هو العمود المرغوب ترحيله الى رقم اليوزر

نعم اخي لاكن ما الغرض من تسلسل رقم السيارة على ورقة التقرير يمكنك نسخ البيانات دون الاعتماد على وجود رقم السيارة مسبقا في حالتك هده يمكنك الاعتماد على عدد الصفوف لكل جدول والتي سوف تجبرك على توحيد عدد الصفوف على جميع الجداول مادا لم تمت اظافة رقم السيارة بعدد يتجاوز عدد الصفوف المقترحة مسبقا وهي على ملفك 60 صف ؟ على العموم تم تعديل الكود على حسب تصميمك للملف ربما يناسبك Option Explicit Sub Filter_ListUniques() Dim WS As Worksheet: Dim src As Worksheet Set WS = Worksheets("1"): Set src = Worksheets("التقرير") Dim Lastrow&, f&, n& Dim list As Object, item As Variant, Rng As Range, tmp As Range Set list = CreateObject("System.Collections.ArrayList") Application.ScreenUpdating = False Intersect(src.Range(src.Rows(2), src.UsedRange.Rows(src.UsedRange.Rows.Count)), _ Union(src.Range("A:G"), src.Range("I:J"))).ClearContents Set tmp = WS.Range("A1:J1") With WS If .AutoFilterMode Then .AutoFilterMode = False For Each item In .Range("H2", .Range("H" & .Rows.Count).End(xlUp)) If Not list.Contains(item.Value) Then list.Add item.Value Next End With For Each item In list With tmp .AutoFilter 8, item '<<======Car number column Lastrow = WS.Cells(WS.Rows.Count, "H").End(xlUp).Row WS.Range("a2:j" & Lastrow).SpecialCells(xlCellTypeVisible).Copy If WorksheetFunction.CountA(src.Range("a:a")) = 1 Then n = src.Cells(src.Rows.Count, "a").End(xlUp).Row + 1 Else 'The number of rows between tables n = n + 61 End If src.Range("a" & n).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Application.CutCopyMode = False 'Copy column headings src.Range("a" & n - 1 & ":j" & n - 1).Value = tmp.Value .AutoFilter End With Next Application.ScreenUpdating = True End Sub تقرير V2.xlsb

تفضل اخي Option Explicit Sub filtre() Dim f$, Lastrow&, Cnt&, n&: f = "من المدرسة" Dim WS As Worksheet: Set WS = Sheets("الصف الثانى ") Dim src As Worksheet: Set src = Sheets("محولين الى المدرسة") Application.ScreenUpdating = False src.Range("B10:U" & src.Rows.Count).ClearContents Lastrow = WS.Range("V" & WS.Rows.Count).End(xlUp).Row For Cnt = 10 To Lastrow If UCase(WS.Range("V" & Cnt).Value) Like f Then n = n + 1 src.Range("B" & n + 9 & ":U" & _ n + 9).Value = WS.Range("B" & Cnt & ":U" & Cnt).Value End If Next Application.ScreenUpdating = True End Sub لتنفيد الكود تلقائيا عند التغيير في عمود التحويلات المدرسية (الصف الثانى ) Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("V10:V600")) Is Nothing Then Application.EnableEvents = False Application.Run ("filtre") Application.EnableEvents = True End If End Sub سجل مستجدين - 2025 V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته طلبك غير واضح !!!!! أظن أنه سبق التطرق إلى هذا الموضوع مسبقا بفكره مشابهة نوعا ما يرجى مراجعة الرابط التالي ربما يفيدك

اخي الفاضل صفحة الصف الثانى فارغة زيادة انك لم تدكر لنا ماهو النطاق او الاعمدة المرغوب ترحيلها يرجى اظافة بعض البيانات الوهمية على الملف مع ارفاق عينة للنتائج المتوقعة .ربما نستطيع مساعدتك

السلام عليكم ورحمة الله تعالى وبركاته ضع الصيغة التالية في الخلية (E6) مع سحبها للاسفل =IFERROR(INDEX($J$6:$J$11,MATCH(TRUE,MMULT(--(ROW($J$6:$J$11)>=TRANSPOSE(ROW($J$6:$J$11))),$I$6:$I$11)>=ROWS($1:1),0)),"") في حالة الرغبة بتسلسل عمود المدة بقدر بيانات عمود المبلغ في الخلية (F6) مع سحب المعادلة للاسفل =IF(E6<>"",ROWS($A$1:A1),"") Book1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته اظن انه يوجد طرق افضل لكتابة الاكواد للحصول على نتائج صحيحة وأدق على العموم حاول تجربة تغيير التنسيق بما يناسبك كما في المثال التالي TextBox4.Value = Format(ws.Cells(X, 11).Value, "mm/yyyy") TextBox18.Value = Format(ws.Cells(X, 23).Value, "dd/mm/yyyy") TextBox19.Value = Format(ws.Cells(X, 24).Value, "dd/mm/yyyy")

لايمكن الاشتغال على صورة المرجوا ارفاق ملفك مع عينة للنتائج المتوقعة

وعليكم السلام ورحمة الله تعالى وبركاته كما سبق الذكر من طرف الأستاذ @طارق محمود أنسب طريقة لتنفيد طلبك على ما أعتقد هي إستخدام الأكواد خاصة إذا كانت لك رغبة بالإشتغال على الملفات وهي مغلقة مع وضع عدة معايير للتحقق يمكنك تجربة هدا الاقتراح ربما يناسبك يكفي وضع مصنف المطابقة في نفس مسار الملفات سيتم تحديث البيانات تلقائيا Sub CopyData() '''''''''( رصيد عملاء Workbook ) Dim FileName$, Path$, wbSource$, rng As Range, FilePath$, sPath$ Dim src As Worksheet: Set src = Sheets("1") Path = ThisWorkbook.Path wbSource = "رصيد عملاء.xlsx": FileName = src.[A1] If FileName = "" Then: Exit Sub ' التححق من وجود المصنف FilePath = Path & "\" & wbSource If Len(Dir(FilePath)) = 0 Then MsgBox "الملف غير موجود", vbExclamation, wbSource: Exit Sub End If ' التححق من وجود ورقة العمل sPath = ActiveWorkbook.Path & "\" If Not Verification(sPath, wbSource, FileName) Then MsgBox wbSource & " " & " الورقة " & " : " & FileName & " غير موجودة على مصنف", vbInformation: Exit Sub End If With Application .ScreenUpdating = False .DisplayAlerts = False src.Range("B3:P" & src.Rows.Count).ClearContents a = "B3:B300": b = "C3:C300": c = "D3:P300" '<<===== ' Paste data(المطابقة) Cnt = "Q12:Q300": Cnt2 = "S12:S300": Cnt3 = "CB12:CN300" '<<===== 'Data range(رصيد عملاء) 'كود المنتج src.Range(a).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt 'المنتج src.Range(b).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt2 ' من يناير الى الإجمالى src.Range(c).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt3 ling = src.UsedRange.Rows.Count: Set rng = src.Range("B3:P" & ling) With rng .Value = .Value: .Borders.LineStyle = xlNone .Replace "#N/A", "", xlWhole: .Replace "0", "", xlWhole End With ' Underline the rows Sheets("1") For Each c In rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next .ScreenUpdating = False .DisplayAlerts = False End With End Sub Sub CopyData2() '''''''''''''( عملاء Workbook ) Dim FileName$, Path$, wbSource$, rng As Range, FilePath$, sPath$ Dim src As Worksheet: Set src = Sheets("1") Path = ThisWorkbook.Path wbSource = "عملاء.xlsx": FileName = src.[R1] If FileName = "" Then: Exit Sub FilePath = Path & "\" & wbSource If Len(Dir(FilePath)) = 0 Then MsgBox "الملف غير موجود", vbExclamation, wbSource: Exit Sub End If sPath = ActiveWorkbook.Path & "\" If Not Verification(sPath, wbSource, FileName) Then MsgBox wbSource & " " & " الورقة " & " : " & FileName & " غير موجودة على مصنف", vbInformation: Exit Sub End If With Application .ScreenUpdating = False .DisplayAlerts = False src.Range("S3:AG" & src.Rows.Count).ClearContents a = "S3:S300": b = "T3:T300": c = "U3:AG300" '<<===== ' Paste data(المطابقة) Cnt = "Y4:Y300": Cnt2 = "Z4:Z300": Cnt3 = "FK4:FW300" '<<===== 'Data range(عملاء) 'كود المنتج src.Range(a).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt 'المنتج src.Range(b).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt2 ' من يناير الى الإجمالى src.Range(c).FormulaArray = "='" & Path & "\[" & wbSource & "]" & FileName & "'!" & Cnt3 ling = src.UsedRange.Rows.Count: Set rng = src.Range("S3:AG" & ling) With rng .Value = .Value: .Borders.LineStyle = xlNone .Replace "#N/A", "", xlWhole: .Replace "0", "", xlWhole End With ' Underline the rows Sheets("1") For Each c In rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next .ScreenUpdating = False .DisplayAlerts = False End With End Sub Function Verification(fPath As String, fName As String, sheetName As String) Dim f As String f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1" Verification = Not IsError(Application.ExecuteExcel4Macro(f)) End Function Sheets("1") وفي حدث Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Select Case Target.Address(0, 0) Case "A1": Call CopyData: Case "R1": Call CopyData2 Target.Select Case Else: Exit Sub End Select End Sub Workbook event Private Sub Workbook_Open() Call CopyData: Call CopyData2 End Sub إستدعاء بيانات.zip

ادن جرب هدا ربما يفيدك Sub Locked(ByVal bEnabled As Boolean) Dim sh As Worksheet, tmp As Integer, Cnt As Integer Set WS = Sheets("واجهة البرنامج") If bEnabled = True Then Cnt = -1 '<<==== Visible tmp = 2 '<<==== Hidden Else Cnt = 2 tmp = -1 End If With ThisWorkbook On Error Resume Next Application.ScreenUpdating = False WS.Visible = Cnt For Each sh In .Sheets If Not sh.Name = WS.Name Then sh.Visible = tmp End If Next sh WS.Visible = Cnt Application.ScreenUpdating = True On Error GoTo 0 End With End Sub Sub Verification() With ThisWorkbook Application.DisplayAlerts = False If .Path <> vbNullString Then .ChangeFileAccess xlReadOnly ' Kill .FullName '<<==== لحدف المصنف نهائيا End If .Close SaveChanges:=False End With End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Locked True ActiveWorkbook.Protect Structure:=True, Windows:=False, Password:="1234" End Sub Private Sub Workbook_Open() Select Case Environ("COMPUTERNAME") Case "HP ZBook Power", "Your device name" ' '<<==== أسماء أجهزة الكمبيوتر المعتمدة Locked False ActiveWorkbook.Unprotect "1234" Case Else Verification End Select End Sub Password 1234 فتح المصنف على اجهزة محددة.xlsm

تفضل جرب هدا Private Sub b_recup_Click() Dim Cnt As VbMsgBoxResult Dim sht As Worksheet, tbl As ListObject, tblRow As ListRow Set sht = Sheets("تصدير بيانات اكسيل") Set tbl = sht.ListObjects("Table1") Cnt = MsgBox(" تــرحيل البيانات ؟", vbYesNo, sht.Name): If Cnt <> vbYes Then Exit Sub With tbl.DataBodyRange If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete End If End With tbl.DataBodyRange.Rows(1).ClearContents Set tblRow = tbl.ListRows.Add tblRow.Range.Resize(Me.ListBox1.ListCount) = Me.ListBox1.List sht.[b2] = Format(DateAdd("d", -1, CDate(Me.DateMini.Value)), "dd/mm/yyyy") sht.[C2] = ("رصيد المدة"): sht.[F2] = ("بيان رصيد أول مدة بتاريخ هذا اليوم") sht.[G2] = Text_count: sht.[I2] = Text_count With sht.Cells(sht.Rows.Count, 6).End(xlUp).Offset(1) .Value = "الإجمالي" .Offset(, 1) = Me.TextBox3.Value .Offset(, 2) = Me.TextBox2.Value .Offset(, 3) = Me.TextBox1.Value End With MsgBox "تم نرحيــل البيانات بنجاح" Unload Me On Error Resume Next Set Rng = sht.Range("A1").CurrentRegion sht.PageSetup.PrintArea = Rng.Address sht.PrintPreview ' answer = MsgBox("طباعــة التقرير ؟", vbQuestion + vbYesNo + vbDefaultButton2, "تأكـــيد") ' If answer = vbYes Then sht.PrintOut End Sub تمت اظافة اكواد تصدير الملف بصيغة Word, Excel, PDF في الملف المرفق Copy of كشف حساب عميل & كارت صنف V5.xlsm

أخي @Armia Nabilرقم السيارة مكرر على طول العمود مثلا الرقم 125 هل يحب ترحيل البيانات على جميع الصفوف ام فقط الصف الأول تفضل اختار ما يناسبك Option Explicit Sub test1() Dim WS As Worksheet, dest As Worksheet Dim c As Range, f As Range Set WS = Sheets("1"): Set dest = Sheets("التقرير") Application.ScreenUpdating = False For Each c In WS.Range("H2", WS.Range("H" & Rows.Count).End(3)) Set f = dest.Range("H:H").Find((c.Value), , xlValues, xlWhole, , , False) If Not f Is Nothing Then dest.Range("A" & f.Row & ":j" & f.Row).Value = WS.Range("A" & c.Row & ":j" & c.Row).Value End If Next Application.ScreenUpdating = True End Sub '======================== Sub test2() Dim WS As Worksheet, dest As Worksheet Dim Lastrow As Long, i As Long, rng As Range, code As Variant Set WS = Sheets("1"): Set dest = Sheets("التقرير") Lastrow = WS.Cells(WS.Rows.Count, "H").End(xlUp).Row Application.ScreenUpdating = False With dest Intersect(.Range(.Rows(2), .UsedRange.Rows(.UsedRange.Rows.Count)), Union(Range("A:G"), .Range("I:J"))).ClearContents End With For i = 2 To Lastrow: code = WS.Cells(i, "H").Value Set rng = dest.Columns("H").Find(What:=code, LookIn:=xlValues, LookAt:=xlWhole) If Not rng Is Nothing Then dest.Cells(rng.Row, "A").Resize(1, 10).Value = WS.Cells(i, "A").Resize(1, 10).Value End If Next i Application.ScreenUpdating = True End Sub '================================= Sub test3() Dim WS As Worksheet, dest As Worksheet Dim cel As Range, r As Range, tmp As Range Set WS = Sheets("1"): Set dest = Sheets("التقرير") Application.ScreenUpdating = False For Each tmp In dest.Range("H2:H" & dest.Cells(Application.Rows.Count, 8).End(xlUp).Row) Set r = WS.Columns(8).Find(tmp.Value, , xlValues, xlPart) If Not r Is Nothing Then dest.Range("A" & tmp.Row & ":j" & tmp.Row).Value = WS.Range("A" & r.Row & ":j" & r.Row).Value End If Next tmp Application.ScreenUpdating = True End Sub تقرير.xlsb

يمكنك جلب اخر قيمة على الليست بوكس باستبدال هده السطور tb = sum1 - sum2 TextBox1.Value = Format(tb, "#,##00.00") وجعلها هكدا With Application sum3 = .Max(.Index(Me.ListBox1.List, r, 9)) ' الرصيد الختامى End With TextBox1.Value = Format(sum3, "#,##00.00") Copy of كشف حساب عميل -V4.xlsm

ربما عليك مراجعة هدا Cnt = Cnt + 1 '===>> ' عدد الصفوف على الليست بوكس sum1 = sum1 + .List(R, 10) '===>> ' مجموع الصفوف الظاهرة ( عمود المبيعات) sum2 = sum2 + .List(R, 11) '===>> ' مجموع الصفوف الظاهرة ( عمود التحصيل) '==================================== 'المبيعات - التحصيل tb = sum1 - sum2 بمعنى عند البحث بين تاريخين سيتم احتساب الاعمدة الظاهرة على الليست بوكس فقط مثلا الفترة المختارة لا يوجد اي بيانات على اعمدة المبيعات و التحصيل لهدا من الطبيعي اظهار 0

المرجوا توضيح طلبك اكثر او ارفاق عينة للنتائج المتوقعة

جرب هل هدا ما تقصده tb1 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!G4:G100000,'" & WS.Name & _ "'!C4:C100000,{""مبيعات"";""قيد""},'" & WS.Name & "'!B4:B100000,""<""&'" & WS.Name & "'!Y1))") tb2 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!H4:H100000,'" & WS.Name & _ "'!C4:C100000,{""مردودات مبيعات"";""سند قيد"";""سند قبض""},'" & WS.Name & "'!B4:B100000,""<""&'" & WS.Name & "'!Y1))") result = tb1 - tb2 Me.Text_count.Value = Format(result, "#,##00.00") If Me.Text_count = 0 Then colDates كما ترى في الصورة التواريخ تظهر معي بالشكل المطلوب قم بتعديل تنسيق التاريخ على الجهاز الخاص بك الى dd/mm/yyyy او تعديل الكود Sub Filtre() If Me.DateMini = "" Or Me.DateMaxi = "" Then Exit Sub For i = 1 To 3 Me.Controls("TextBox" & i).Value = "" Next i S.Caption = "" Dim Tbl() cbx1 = Me.ComboBox1: cbx2 = Me.ComboBox2: cbx3 = Me.ComboBox3 n = 0 dMini = CDate(Me.DateMini): dMaxi = CDate(Me.DateMaxi) Cb = Array(1, 1, 1) For i = 0 To UBound(ColCombo): Cb(i) = ColCombo(i): Next i For i = 1 To UBound(TabBD) If TabBD(i, Cb(0)) Like cbx1 And TabBD(i, Cb(1)) Like cbx2 _ And TabBD(i, Cb(2)) Like cbx3 _ And TabBD(i, 2) >= dMini And TabBD(i, 2) <= dMaxi Then n = n + 1: ReDim Preserve Tbl(1 To Irow + 1, 1 To n) c = 0 For c = 1 To Irow: Tbl(c, n) = TabBD(i, c): Next c Tbl(c, n) = TabBD(i, Irow + 1) Tbl(2, n) = Format(TabBD(i, 2), "dd/mm/yyyy") ' تنسيق عمود التاريخ End If Next i If n > 0 Then Me.ListBox1.Column = Tbl SUMIF Else Me.ListBox1.Clear End If End Sub Copy of كشف حساب عميل -V3.xlsm

حاول تجربة هدا من خلال اليوزرفورم Dim f Private Sub UserForm_Initialize() Set f = Sheets("ClassSheet") Set d = CreateObject("Scripting.Dictionary") For Each c In f.Range("b2:b" & f.[b65000].End(xlUp).Row) d(c.Value) = "" Next c Me.ComboBox1.List = d.keys End Sub Private Sub ComboBox1_Change() Set d = CreateObject("Scripting.Dictionary") For Each c In f.Range("b2:b" & f.[b65000].End(xlUp).Row) If c.Value = Me.ComboBox1 Then d(c.Offset(0, -1).Value) = "" Next c Me.ComboBox2.List = d.keys Me.ComboBox2.ListIndex = -1 Me.ComboBox3.ListIndex = -1 End Sub Private Sub ComboBox2_Change() Set d = CreateObject("Scripting.Dictionary") For Each c In f.Range("b2:b" & f.[b65000].End(xlUp).Row) If c.Value = Me.ComboBox1 And _ c.Offset(0, -1).Value = Me.ComboBox2 Then _ d(c.Offset(0, 1).Value) = "" Next c Me.ComboBox3.List = d.keys Me.ComboBox3.ListIndex = -1 End Sub Private Sub b_validation_Click() If Me.ComboBox1 <> "" Then ActiveCell.Offset(0, 2).Value = Me.ComboBox1.Value If Me.ComboBox2 <> "" Then ActiveCell.Value = Me.ComboBox2.Value If Me.ComboBox3 <> "" Then ActiveCell.Offset(0, 4).Value = Me.ComboBox3.Value Unload Me End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect(Target, Sheet1.Range("b8:b200")) Is Nothing Then UserForm1.Show End If End Sub All.BOQ V2.xlsm

جرب هدا Sub SUMIF() Dim WS As Worksheet: Set WS = Sheets("كشف حساب") Dim sum As Double, Cnt As Long WS.[Y1] = CDate(Me.DateMini) Cnt = 0: sum1 = 0: sum2 = 0 On Error Resume Next With ListBox1 For R = 0 To .ListCount - 1 Cnt = Cnt + 1 sum1 = sum1 + .List(R, 10) sum2 = sum2 + .List(R, 11) Next R End With Me.S.Caption = Cnt TextBox3.Value = Format(sum1, "#,##00.00"): TextBox2.Value = Format(sum2, "#,##00.00") tb = sum1 - sum2 TextBox1.Value = Format(tb, "#,##00.00") tb1 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!G4:G100000,'" & WS.Name & _ "'!C4:C100000,{""مبيعات"";""قيد""},'" & WS.Name & "'!B4:B100000,""<=""&'" & WS.Name & "'!Y1))") tb2 = Evaluate("=SUM(SUMIFS('" & WS.Name & "'!H4:H100000,'" & WS.Name & _ "'!C4:C100000,{""مردودات مبيعات"";""سند قيد"";""سند قبض""},'" & WS.Name & "'!B4:B100000,""<=""&'" & WS.Name & "'!Y1))") result = tb1 - tb2 Me.Text_count.Value = Format(result, "#,##00.00") End Sub Copy of كشف حساب عميل V2.xlsm

لقد تم الاشتغال على 95 في المئة من المطلوب يتبقى لك تعديل الاكواد بما يناسيك للحصول على نتائج عناصر Textbox او ارفاق عينة للنتائج المتوقعة يدويا ربما نستطيع مساعدتك Option Compare Text Dim f, NomTableau, TabBD(), ColCombo(), colVisu() Dim colInterro(), Irow, NcolInt, Choix() Private Sub UserForm_initialize() Set f = Sheet1 Set Rng = f.Range("A3:L" & f.[a65000].End(xlUp).Row) NomTableau = "Tableau1" Irow = Range(NomTableau).Columns.Count TabBD = Range(NomTableau).Resize(, Irow + 1).Value For I = 1 To UBound(TabBD): TabBD(I, Irow + 1) = I: Next I ColCombo = Array(3, 4, 5) colVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) colInterro = colVisu Me.ListBox1.ColumnWidths = "55;80;80;60;60;100;55;55;45;55" NcolInt = UBound(colInterro) + 1 Me.ListBox1.List = TabBD For I = UBound(ColCombo) + 1 To 2 Me("combobox" & I + 1).Visible = False: Me("Cnt" & I + 1).Visible = False Next I For c = 1 To UBound(ColCombo) + 1: Me("combobox" & c) = "*": Next c For c = 1 To UBound(ColCombo) + 1: ListeCol c: Next c For I = 1 To UBound(ColCombo) + 1: Me("Cnt" & I) = Range(NomTableau).Offset(-1).Item(1, ColCombo(I - 1)): Next I Me.ListBox1.ColumnCount = Irow + 1 colDate = 2 Set d = CreateObject("scripting.dictionary") For I = LBound(TabBD) To UBound(TabBD) d(TabBD(I, colDate)) = "" Next I Dates = d.keys Me.DateMini.List = Dates: Me.DateMini = Dates(0) Me.DateMaxi.List = Dates: Me.DateMaxi = Dates(UBound(Dates)) Me.Frame1.ScrollWidth = Me.ListBox1.Width + 10 Me.Frame1.ScrollBars = 1 For I = 1 To 12: Me("label" & I) = f.Cells(3, I): Next I Me.ComboTri.List = Application.Transpose(Range(NomTableau).Offset(-1).Resize(1)) Filtre B_ajout_Click ' Me.DateMini.Value = FormatDateTime(WorksheetFunction.EDate(Date, -1)) ' Me.DateMaxi.Value = FormatDateTime(Date, vbShortDate) End Sub Sub Filtre() If Me.DateMini = "" Or Me.DateMaxi = "" Then Exit Sub For I = 1 To 3 Me.Controls("TextBox" & I).Value = "" Next I S.Caption = "" Dim Tbl() cbx1 = Me.ComboBox1: cbx2 = Me.ComboBox2: cbx3 = Me.ComboBox3 n = 0 dMini = CDate(Me.DateMini): dMaxi = CDate(Me.DateMaxi) Cb = Array(1, 1, 1) For I = 0 To UBound(ColCombo): Cb(I) = ColCombo(I): Next I For I = 1 To UBound(TabBD) If TabBD(I, Cb(0)) Like cbx1 And TabBD(I, Cb(1)) Like cbx2 _ And TabBD(I, Cb(2)) Like cbx3 _ And TabBD(I, 2) >= dMini And TabBD(I, 2) <= dMaxi Then n = n + 1: ReDim Preserve Tbl(1 To Irow + 1, 1 To n) c = 0 For c = 1 To Irow: Tbl(c, n) = TabBD(I, c): Next c Tbl(c, n) = TabBD(I, Irow + 1) End If Next I If n > 0 Then Me.ListBox1.Column = Tbl SUMIF Else Me.ListBox1.Clear End If End Sub '******************************** Sub SUMIF() Dim sum As Double Dim Cnt As Long Cnt = 0: sum1 = 0: sum2 = 0 On Error Resume Next With ListBox1 For R = 0 To .ListCount - 1 Cnt = Cnt + 1 sum1 = sum1 + .List(R, 10) sum2 = sum2 + .List(R, 11) Next R End With Me.S.Caption = Cnt TextBox3.Value = sum1: TextBox2.Value = sum2: TextBox1.Value = sum1 - sum2 TextBox1.Value = Format(Val(Replace(TextBox1.Value, ",", ".")), "#,##00.00") TextBox2.Value = Format(Val(Replace(TextBox2.Value, ",", ".")), "#,##00.00") TextBox3.Value = Format(Val(Replace(TextBox3.Value, ",", ".")), "#,##00.00") End Sub Copy of كشف حساب عميل.xlsm