محمد هشام.

العفو أخي الكريم يسعدنا أننا استطعنا مساعدتك

Set wsdata = Feuil2 ملاحظة: إذا كنت تقوم بنسخ الكود فقط إلى ملف الأصلي. حاول تعديل أسماء أوراق العمل لديك لتتطابق مع الأسماء الموجودة في القائمة المنسدلة في عمود G لأنها غير مطابقة وتم إصلاحها في الملفات السابقة. مجرد وجود اختلاف في حرف أو فراغ معين. قد يسبب عدم اشتغال الكود معك بشكل جيد ترحيل بيانات5.xlsm

أرفق ملفك الأصلي مع صورة توضح الخطأ الذي يظهر معك هل قمت بتجربة الملف الذي رفعت لك في آخر مشاركة ؟

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

جرب هدا الحل هل يناسبك هيثم -2.xlsx

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

نعم أخي ربما لم تلاحظ التغيير فقط اجعل كلمة وارد داخل المعادلة بهذا الشكل *وارد*

سؤالك غير واضح لاكن ربما هدا ما تقصد =IFERROR(1/(1/MAXIFS($G$3:G1000;$A$3:$A1000;"="&J12;$E$3:$E1000;"="&"*وارد*"));"")

بما انك لم تقم بنشر الكود بالكامل لنتمكن من تحديد عنصر التغيير لديك و على حسب تخميني انك تستخدم يوزرفورم اليك نمودج للحل يمكنك تطويعه على حسب احتياجاتك وكما سبق الدكر انه يوجد صعوبة لانشاء الكود الصحيح ما دمت لم تقم برفع ملف يتضمن طلبك بشكل اوضح لنفترض انك تقوم باختبار البيانات عن طريق Combobox1 '''''''''''''''طريقة رقم 1'''''''''''''''''''' Private Sub ComboBox1_Change() For bgg = 1 To 17 If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 4, 0) = "نعم" Then Me("CheckBox" & bgg).Caption = True Else Me("CheckBox" & bgg).Caption = False End If Next End Sub ''''''''''''''طريقة رقم 2'''''''''''''''''''' 'Private Sub ComboBox1_Change() 'Dim bgg As Control, réf As String, col As Range 'Set WS = Sheet1: Set col = WS.Range("B2:E" & WS.[B65000].End(xlUp).Row) 'For Each bgg In Me.Controls 'réf = Me.ComboBox1.Text 'If Application.WorksheetFunction.VLookup(réf, col, 4, False) = "نعم" Then ' If TypeName(bgg) = "CheckBox" Then bgg.Caption = True ' Else ' If TypeName(bgg) = "CheckBox" Then bgg.Caption = False 'End If 'Next 'End Sub ''''''''''''''طريقة رقم 3'''''''''''''''''''' 'For Each bgg In UserForm1.Controls 'If TypeName(bgg) = "CheckBox" Then 'If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 4, 0) = "نعم" Then bgg.Caption = True Else bgg.Caption = False 'End If 'Next bgg '''تحديد العناصر''''''طريقة رقم 4'''''''''''''''''''' 'Dim bgg As Control 'For Each bgg In Me.Controls 'If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 2, 0) = "نعم" Then ' If TypeName(bgg) = "CheckBox" Then bgg.Value = True ' Else ' If TypeName(bgg) = "CheckBox" Then bgg.Value = False 'End If 'Next '''التحقق مع تلوين القيمة ''''''طريقة رقم 5'''''''''''''''''''' Private Sub ComboBox1_Change() Dim LR& Set ws = Sheet1 With ws LR = .Cells(.Rows.Count, "B").End(xlUp).Row For bgg = 1 To 17 If Application.WorksheetFunction.VLookup(Me.ComboBox1.Text, Range("B:E"), 4, 0) = "نعم" Then Me("CheckBox" & bgg).Caption = True Else Me("CheckBox" & bgg).Caption = False End If Next For i = 2 To LR .Range("E" & i).Interior.Color = xlNone If .Range("B" & i).Value = Me.ComboBox1.Value And .Range("E" & i).Value = "نعم" Then .Range("E" & i).Interior.Color = vbYellow End If Next i End With End Sub اليك ملف حاولت تنفيد الفكرة عليه لتتمكن من تعديلها بما يناسبك CONTROLS F_VLookup.xlsm

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

اخي قم بازاحة العمود الاول على ورقة الشيكات للحصول على عمود A فارغ ووضع المعادلة التالية مع سحبها الى الاسفل على حسب البيانات الموجودة لديك =IF(G2<>"";COUNTIF($G$2:G2;G2)&"-"&G2;"") وفي ورقة اليومية الخلية Q8 ضع المعادلة الاتية مع سحبها الى الاسفل =IFERROR(VLOOKUP(COUNTIF($A$8:A8;A8)&"-"&A8;الشيكات!$A$2:$G$1000;2;0);"") اليك الملف للتجربة استخراج رقم من البيانV2.xlsx

نعم اخي انت من تختار من الخلية J1 الحركة المرغوب اظهار اخر تاريخ لها او بمكنك تحديدها داخل المعادلة بحيث عند العثور على نوع الحركة يتم جلب اخر تاريخ او ترك الخلية فارغة مع عدم اظهار 00-01-1900 =IFERROR(1/(1/MAXIFS(G3:G1000;$A3:$A1000;"="&J3;$E3:$E1000;"="&"صادر"));"") '""""""""""""""" =IFERROR(1/(1/MAXIFS(G3:G1000;$A3:$A1000;"="&J3;$E3:$E1000;"="&"وارد"));"") ملف.xlsx

=IFERROR(1/(1/MAXIFS(G3:G1000;$A3:$A1000;"="&J3;$E3:$E1000;"="&J1));"") ملف.xlsx

استخراج رقم من البيان.xlsx

هناك حل اخر لاثراء الموضوع . في وجهة نظري سوف يغنيك عن اظافة كل لون على حدى داخل الكود خاصة ادا قمت باظافة الوان اخرى للملف يكفي وضع اسماء الالوان المستخدمة مثلا في عمود AG وتلوين خلية العمود المجاور وليكن مثلا AH باللون المطلوب كما في الصورة اسفله واستخدام الكود التالي Sub Spinner2_Change() Dim myRange As Range, cell As Range 'نطاق البيانات Set myRange = Range("F5:F33") With Application .ScreenUpdating = False On Error Resume Next With myRange .Interior.ColorIndex = xlColorIndexNone: .Font.Color = RGB(0, 0, 0) End With For Each cell In myRange If Not IsError(.Match(cell.Value, Columns("AG"), 0)) Then ' عمود اسماء الالوان ' لون الخلفية cell.Interior.Color = Cells(.Match(cell.Value, Columns("AG"), 0), "AH").Interior.Color ' عمود الالوان ' لون الخط cell.Font.Color = Cells(.Match(cell.Value, Columns("AG"), 0), "AH").Interior.Color End If Next .ScreenUpdating = True End With On Error GoTo 0 End Sub تلوين 3.xlsm

تفضل اخي تم وضع الكود في المكان المناسب تلوين.xlsm

صراحة لم استوعب طلبك جيدا لاكن جرب وضع هدا الكود في module Option Explicit Public Sub ColourChange() Dim Clé As Range For Each Clé In ActiveWorkbook.ActiveSheet.Range("F5:F36") Application.ScreenUpdating = False If Not IsError(Clé) Then With Clé .Interior.ColorIndex = xlColorIndexNone: .Font.Color = RGB(0, 0, 0) Select Case .Value2 Case "اخضر", "أخضر" .Interior.Color = RGB(0, 204, 0): .Font.Color = RGB(0, 204, 0) Case "ازرق", "أزرق" .Interior.Color = RGB(0, 0, 255): .Font.Color = RGB(0, 0, 255) Case "اصفر", "أصفر" .Interior.Color = RGB(255, 255, 0): .Font.Color = RGB(255, 255, 0) Case "احمر", "أحمر" .Interior.Color = RGB(255, 0, 0): .Font.Color = RGB(255, 0, 0) End Select End With End If Next Application.ScreenUpdating = True End Sub وفي حدث ورقة شهادات ضع الرمز التالي ' على حسب احتياجاتك Private Sub Worksheet_Activate() ColourChange End Sub ' او Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("F5:F36")) Is Nothing Then If Target.Cells.Value = Empty Then Exit Sub Aplication.EnableEvents = False Call ColourChange Application.EnableEvents = True On Error GoTo 0 End If End Sub

Copy of مسلسل فاتورة على حسب نوع الفاتورة.xlsm

=COUNTIF(K5:K21;">""")

بعد ادن الاخ @AbuuAhmed اليك حل اخر على حسب الشروط المدكورة والصورة المرفقة في في اول مشاركة Sub Color_Friday() Dim lastCol&, LastRow&, i&, j&, lr&, Search As String Dim WS As Worksheet: Set WS = ThisWorkbook.Worksheets("Base") Search = "الجمعة" Application.ScreenUpdating = False With WS lr = .Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row lastCol = .Cells(5, WS.Columns.Count).End(xlToLeft).Column LastRow = .Range("B" & .Rows.Count).End(xlUp).Row WS.Range("D5:AH" & lr).Interior.ColorIndex = xlNone .Range(Cells(5, 4), Cells(6, lastCol - 4)).Interior.Color = RGB(217, 217, 217) If lr > 6 Then .Range(Cells(7, 4), Cells(lr, lastCol - 4)).ClearContents End If For j = 7 To LastRow If .Cells(j, 2) <> "" Then .Range(Cells(7, 4), Cells(LastRow, lastCol - 4)).Value = "V" End If For i = 4 To lastCol If WS.Cells(5, i).Value2 Like Search Then .Range(Cells(7, i).Address, Cells(LastRow, i).Address).Value = "P" .Range(Cells(5, i).Address, Cells(LastRow, i).Address).Interior.ColorIndex = 40 End If Next Next End With Application.ScreenUpdating = True End Sub حضور 2وإنصراف.xlsb

Option Explicit Public Sub ColourChange() Dim Clé As Range For Each Clé In ActiveWorkbook.ActiveSheet.Range("C5:N400") Application.ScreenUpdating = False If Not IsError(Clé) Then With Clé .Interior.ColorIndex = xlColorIndexNone Select Case .Value2 Case "اخضر" .Interior.Color = RGB(0, 204, 0): .Font.Color = RGB(0, 204, 0) Case "ازرق" .Interior.Color = RGB(0, 0, 255): .Font.Color = RGB(0, 0, 255) Case "اصفر" .Interior.Color = RGB(255, 255, 0): .Font.Color = RGB(255, 255, 0) Case "احمر" .Interior.Color = RGB(255, 0, 0): .Font.Color = RGB(255, 0, 0) End Select End With End If Next Application.ScreenUpdating = True End Sub تلوين.xlsm

او Sub Filtre2() Dim wb As Workbook, ws As Worksheet, Dest As Worksheet Set wb = ThisWorkbook: Set ws = wb.Sheets("البيانات"): Set Dest = wb.Sheets("كشف حساب") Dim I&, Col&, ligne&, rng As Range Col = 1 ligne = ws.Cells(Rows.Count, Col).End(xlUp).Row Application.ScreenUpdating = False Dest.Range("A4:H100").ClearContents For I = 4 To ligne If ws.Cells(I, Col) = ws.[G1] And ws.Cells(I, Col + 2) >= Dest.[D2] And ws.Cells(I, Col + 2) <= Dest.[F2] Then Set rng = ws.Range(ws.Cells(I, 1), ws.Cells(I, 8)) Dest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 8).Value = rng.Value End If Next I Application.ScreenUpdating = True End Sub

Public Property Get ws() As Worksheet: Set ws = Feuil1 End Property Public Property Get Dest() As Worksheet: Set Dest = Feuil2 End Property Sub Filtre() Rng = ws.Range("A4:H" & ws.[A65000].End(xlUp).Row).Value Col = 3: date1 = Dest.Range("D2"): date2 = Dest.Range("F2"): S = 1: P = ws.Range("G1") On Error Resume Next If date1 > date2 Then: Exit Sub For i = 1 To UBound(Rng) If Rng(i, Col) >= date1 And Rng(i, Col) <= date2 And Rng(i, S) = P Then n = n + 1 Next i J = 0 Dim réf(): ReDim réf(1 To n, 1 To UBound(Rng, 2)) For i = 1 To UBound(Rng) If Rng(i, Col) >= date1 And Rng(i, Col) <= date2 And Rng(i, S) = P Then J = J + 1: For K = 1 To UBound(Rng, 2): réf(J, K) = Rng(i, K): Next K End If Next i Dest.Range("A4:H100").ClearContents Dest.[A4].Resize(UBound(réf), UBound(réf, 2)) = réf On Error GoTo 0 End Sub العملاء.xlsm

WS = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8")

= SUMIFS(B2:B20, E2:E20, ">="&I2, F2:F20, "<="&J2, C2:C20, L2,D2:D20,K2) =NB.SI.ENS(E2:E20;">="&I2;F2:F20;"<="&J2;D2:D20;K2;C2:C20;L2) الجمع والعد بشروط عدة.xlsx