محمد هشام.

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

اخي قم بازاحة العمود الاول على ورقة الشيكات للحصول على عمود 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

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

لو سمحت ممكن ارفاق صورة للسطر الدي به الخطا مع دكر ما هو اصدار الاوفيس لديك على الجهاز مع العلم ان الملف يشتغل معي بشكل جيد وبدون ادنى مشكلة على نسخة 2021 اليك الرابط التالي https://streamable.com/x84gtp اليك حل اخر 'Private Sub UserForm_Initialize() 'في اخر الكود قم باستبدال الكود الاول بهدا Dim ws, List, tb2(), réf Set ws = PDF List = ws.Range("A2:B" & ws.[A65000].End(xlUp).Row).Value tb2 = Array(1, 2) réf = UBound(tb2) + 1 ' وهدا في حدث التيكست بوكس Private Sub Recherche_Change() a = "*" & Me.Recherche & "*" Dim j(): n = 0 For i = 1 To UBound(List) If List(i, 1) Like a Or List(i, 2) Like a Then n = n + 1: ReDim Preserve j(1 To réf, 1 To n) List(i, 2) = Format(List(i, 2), "dd/mm/yyyy hh:mm") c = 0 For Each k In tb2 c = c + 1: j(c, n) = List(i, k) Next k End If Next i If n > 0 Then Me.ListBox1.Column = j Else Me.ListBox1.Clear End Sub الملف بعد التعديل 4.xls

نعم يتم نسخ بيانات الأعمدة لغاية آخر قيمة على عمود الإسم يمكنك تعديلها بما يناسبك