محمد هشام.

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

سؤالك غير واضح لاكن ربما هدا ما تقصد =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

Sub TEST_Protect() WS = Array("ورقة1", "ورقة4") On Error Resume Next For i = LBound(WS) To UBound(WS) Sheets(WS(i)).Protect userinterfaceonly:=True, Password:="1234" Next i On Error GoTo 0 End Sub كووود.xlsm

الكاشير 7.xlsm

Sub Transfer() Dim Rng As Range, cl As Range, WS As String Dim C As Long, lastrow As Long Dim WSdata As Worksheet: Set WSdata = Worksheets("Main"): WS = WSdata.[l2] If WSdata.[l2] = 0 Then MsgBox "الرجاء اختيار ورقة العمل", vbOKOnly + vbExclamation, "Admin" Exit Sub End If Dim WSdest As Worksheet: Set WSdest = ThisWorkbook.Sheets(WS) Arr = Array([k5], [k6], [k7], [k8], [k9], [k10], [k11], [k12], [k13], [k14]) For i = 0 To 9 If Arr(i) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(i).Offset(0, -2), vbExclamation, "إنتباه" Arr(i).Select Exit Sub End If Next If MsgBox("ترحيل البيانات الى ورقة " & WSdata.[l2] & " ؟", vbYesNo, "admin") = vbNo Then Exit Sub End If Application.ScreenUpdating = False lastrow = WSdest.[b10000].End(xlUp).Row Set Rng = WSdata.Range("k5,k6,k7,k8,k9,k10,k11,k12,k13,k14") C = 2 For Each cl In Rng cl.Copy WSdest.Cells(lastrow + 1, C).PasteSpecial Paste:=xlPasteValuesAndNumberFormats C = C + 1 Next cl Application.CutCopyMode = False Rng.SpecialCells(xlCellTypeConstants, 23).ClearContents Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح", 64, "تأكيد" End Sub ادخال البيانات2.xlsb

Sub Test_Meragr_Celle() 'دمج Dim LastRow As Long Dim i As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With ActiveSheet LastRow = .Range("c" & .Rows.Count).End(xlUp).Row For i = LastRow To 2 Step -1 If .Range("c" & i).Value = .Range("c" & i - 1).Value Then Application.Union(.Range("c" & i).MergeArea, .Range("c" & i - 1)).Merge End If Next i End With Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub '********************************* Sub annulation_Meragr_Celle() ' الغاء الدمج Dim Rng As Range, xCell As Range Set WorkRng = Range("c2:c" & Cells(Rows.Count, 3).End(xlUp).Row) Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Rng In WorkRng If Rng.MergeCells Then With Rng.MergeArea .UnMerge .Formula = Rng.Formula End With End If Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub اختبار.xlsb

جرب هدا Sub TEST() Dim LR As Long, Formul As String Formul = "=IF(B2="""","""",IF(B2<=9,E2&""0""&C2&""00000""&B2,IF(B2<=99,E2&""0""&C2&""0000""&B2)))" Range("N2:N" & Cells(Rows.Count, 2).End(xlUp).Row) = [Formul] LR = Range("B" & Rows.Count).End(xlUp).Row Range(Range("N2"), Range("N" & LR)).FillDown With Range("N2:N" & LR) .Value = .Value End With End Sub

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