محمد هشام.

Sub Remplissez_jours_dates() Dim début As Date, DateFin As Date, CrDate As Date Dim tmp As Long, DayArr As Variant, i As Long Dim WS As Worksheet: Set WS = Sheets("البنين") If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _ Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Or _ WS.Range("K2").Value > WS.Range("O2").Value Then MsgBox "يرجى التأكد من صحة التواريخ " & vbCrLf & _ "وتاريخ البدء لا يكون أكبر من تاريخ الانتهاء", vbExclamation Exit Sub End If début = WS.Range("K2").Value DateFin = WS.Range("O2").Value ' لاخر اسم في عمود b Dim LastRow As Long LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row 'لاخر الكشف الصف 45 ' LastRow = 45 Application.ScreenUpdating = False WS.Range("D4:AH5").ClearContents With WS.Range("D4:AH45") .Interior.Pattern = xlNone .Font.Color = RGB(0, 0, 0) End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Range(WS.Cells(4, tmp), WS.Cells(LastRow, tmp)).Interior.Color = RGB(255, 255, 0) WS.Range(WS.Cells(4, tmp), WS.Cells(5, tmp)).Font.Color = RGB(255, 0, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True End Sub جدول الحصص الإضافية 2.xlsb

début = WS.Range("K2").Value DateFin = WS.Range("O2").Value Set Rng = WS.Range("D4:AH5") If début > DateFin Then : MsgBox "لا يمكن أن يكون تاريخ البدء أكبر من تاريخ الانتهاء", vbExclamation :Exit Sub Application.ScreenUpdating = False With Rng .ClearContents .Interior.ColorIndex = xlNone End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Cells(4, tmp).Interior.Color = RGB(255, 255, 0) WS.Cells(5, tmp).Interior.Color = RGB(255, 255, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True جدول الحصص الإضافية.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا Sub Remplissez_jours_dates() Dim début As Date, DateFin As Date, CrDate As Date Dim tmp As Long, DayArr As Variant Dim WS As Worksheet: Set WS = Sheets("البنين") If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _ Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Then MsgBox "يرجى التأكد من صحة التواريخ ", vbExclamation Exit Sub End If début = WS.Range("K2").Value DateFin = WS.Range("O2").Value If début > DateFin Then: MsgBox "لا يمكن أن يكون تاريخ البدءأكبر من تاريخ الانتهاء", vbExclamation: Exit Sub Application.ScreenUpdating = False WS.Range("E4:AH5").ClearContents DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") tmp = 4 CrDate = début Do While CrDate <= DateFin If Weekday(CrDate, vbSunday) <> 6 And Weekday(CrDate, vbSunday) <> 7 Then If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate tmp = tmp + 1 End If CrDate = CrDate + 1 Loop Application.ScreenUpdating = True End Sub وفي حدث ورقة البنين Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("K2,O2")) Is Nothing Then Remplissez_jours_dates End If End Sub جدول الحصص الإضافية.xlsb

جرب هدا Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range Dim choose As VbMsgBoxResult, DataRng As Range, Cnt As Boolean Set WS = Sheets("ورقة1") Set DataRng = WS.Range("A1:E50") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Cnt = False For i = 3 To lastRow If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then Cnt = True Exit For End If Next i If Not Cnt Then MsgBox "لا توجد بيانات مطابقة للحذف", vbExclamation, "خطأ" Exit Sub End If choose = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") Application.ScreenUpdating = False If choose = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If Next i If Not OnRng Is Nothing Then OnRng.Delete For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i MsgBox "تم حذف الصفوف بنجاح", vbInformation, "الحذف" With WS .PageSetup.TopMargin = .PageSetup.BottomMargin = .PageSetup.LeftMargin = .PageSetup.RightMargin = Application.InchesToPoints(0.5) .[C1].Value = Format(Date - 1, "dd/mm/yyyy") .[B1].Value = Format(Date - 1, "dddd") End With With DataRng.Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" End If Application.ScreenUpdating = True End Sub مثال1 v2.xlsm

DC.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته الإسم المفروض وضع الصيغة التالية في عمود الاسم لاكنها ستقوم باستخراج الأسماء مكررة بعدد تواجدها في عمود الإسم لهدا قم بوضعها مثلا في الخلية Q6 وسحبها للأسفل =IFERROR(INDEX(D$6:D$139,SMALL(IF($H$6=$C$6:$C$139,ROW($D$6:$D$139)-5),ROW(J1))),"") ثم وضع المعادلة التالية في الخلية K6 مع سحبها للأسفل لإستخراج الأسماء بدون تكرار =IFERROR(IF(Q6<>"", INDEX($Q$6:$Q$139, MATCH(0, COUNTIF($K$5:K5, $Q$6:$Q$139) + IF($Q$6:$Q$139="", 1, 0), 0)), ""), "") إجمالي الإسم =IF(K6<>"",SUMIF($D$6:$D$139, K6, $E$6:$E$139),"") إجمالي البيان =SUMIF(C6:C139, H6, E6:E139)

اعتقد أن النتائج على الصورة الخاصة بك غير صحيحة أم أنا قد فهمت طلبك بشكل خاطئ جرب هدا =IF($H$5303<>"", COUNTIFS($D$2:$D$5294, $H$5303, $I$2:$I$5294, G5306), "") او =IF($H$5303<>"", IF(COUNTIFS($D$2:$D$5294, $H$5303, $I$2:$I$5294, G5306) > 0, COUNTIFS($D$2:$D$5294, $H$5303, $I$2:$I$5294, G5306), "لا توجد طلبات"), "") احصاء عدد الطلبات.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب إحدى المعادلات التالية =IF(D5304<>"",COUNTIFS(D2:D5294, D5304),"") أو =IF(D5304<>"",COUNTIF($D$2:$D$5294, D5304), "") ولجلب Driver ID =IFERROR(INDEX($D$2:$D$5294, MATCH(0, IF(($D$2:$D$5294<>"")* ($D$2:$D$5294<>0), COUNTIF($D$5303:D5303, $D$2:$D$5294), ""), 0)), "") احصاء عدد الطلبات.rar

وعليكم السلام ورحمة الله تعالى وبركاته ممكن توضح لنا ما المانع من إظافة عمود التسلسل يدويا وإعادة تعديل الكود بما يتناسب مع شكل البيانات ؟ اذا كان هذا يناسبك إليك الكود المعدل Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range, response As VbMsgBoxResult Set WS = Sheets("ورقة1") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If End If Next i If Not OnRng Is Nothing Then OnRng.Delete MsgBox OnRng.Count & " تم حذف الصفوف بنجاح", vbInformation, "عملية الحذف" Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" Exit Sub End If With WS.Range("A1:E50").Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i With WS.PageSetup .TopMargin = .BottomMargin = .LeftMargin = .RightMargin = Application.InchesToPoints(0.5) End With WS.[C1].Value = Date - 1: WS.[C1].NumberFormat = "dd/mm/yyyy" WS.[B1].Value = Format(Date - 1, "dddd") Application.ScreenUpdating = True End Sub مثال1.xlsm

اخي @أبوالباسل دالة VLOOKUP لديها قاعدة أساسية يجب الإنتباه إليها فهي تعمل فقط من اليسار إلى اليمين بمعنى تبحث دائما في العمود الأول من النطاق المحدد وهو في حالتك العمود G لكنك تريد البحث عن رقم سير باستخدام العمود H (الذي يحتوي على أسماء العملاء) وهذا يخالف طريقة عمل VLOOKUP لأن العمود H ليس العمود الأول بإختصار دالة VLOOKUP لا يمكنها البحث في عمود ليس هو الأول ضمن نطاق البيانات لهدا حاولنا إستخدام بدائل أخرى مثل INDEX و MATCH هذه الدوال لا تعتمد على ترتيب الأعمدة للتوضيح أكثر حاول عكس ترتيب الأعمدة بجعل عمود أسماء العملاء على اليمين وجعل عمود سير يسارا ووضع المعادلة الخاصة بك على الشكل التالي =IF(C3<>"", IFERROR(VLOOKUP(C3, $G$3:$H$121, 2, 0), "غير موجود"), "") كما تلاحظ VLOOKUP الآن تبحث في العمود H (أسماء العملاء) لأنه أصبح العمود الأول و تسترجع القيمة المقابلة من العمود G (سير ) بنجاح خط السير-VLOOKUP.xlsx

تفضل أخي تم تعديل الكود السابق وإظافة إمكانية تحديد الأعمدة المرحلة والمرحل إليها لتتمكن من تعديله بما يناسبك لاحقا Option Explicit Dim tmp As Variant Const tmpCol As String = "G" Private Sub Worksheet_Change(ByVal Target As Range) Dim arr(3) As Worksheet, OnRng As Range, Irow As Long, ling As Variant Set arr(0) = Sheets("بطاقة صنف"): Set arr(1) = Sheets("اضافة") Set arr(2) = Sheets("الصرف"): Set arr(3) = Sheets("الأصناف") If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then SetApp False Set OnRng = arr(0).Range("B6:I" & arr(0).Rows.Count) OnRng.ClearContents Irow = arr(3).Cells(arr(3).Rows.Count, 1).End(xlUp).Row Me.Range("I3").Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & Irow & ",2,0),"""")" Me.Range("I3").Value = Me.Range("I3").Value ling = Me.Range("I3").Value If Not IsEmpty(ling) And ling <> "" Then tmp = ling Call Cnt(arr(1), arr(0), ling, Array(4, 9, 10, 14, 16), Array(3, 5, 6, 4, 2)) Call Cnt(arr(2), arr(0), ling, Array(4, 19, 17, 9, 10, 11), Array(3, 2, 4, 7, 8, 9)) Else OnRng.ClearContents GoTo AppTrue End If AppTrue: SetApp True End If End Sub '"""""""""""""""""""""""""""""""""""" Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _ ByVal temp As Variant, ByVal Colky As Variant, ByVal DestCols As Variant) Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range, début As Long, fin As Long LastRow = dest.Cells(dest.Rows.Count, tmpCol).End(xlUp).Row début = 3 fin = LastRow For i = début To fin With dest If Not IsEmpty(.Cells(i, tmpCol).Value) And Not IsError(.Cells(i, tmpCol).Value) Then If .Cells(i, tmpCol).Value = temp Then x = WorksheetFunction.CountA(tbl.Range("B6:B1000")) For n = LBound(Colky) To UBound(Colky) Set Cel = tbl.Cells(6 + x, DestCols(n)) Cel.Value = .Cells(i, Colky(n)).Value Next n End If End If End With Next i End Sub '""""""""""""""""""""""""""""" Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مخازن 2024مكرو v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب إستخدام إحدى الصيغ التالية =IFERROR(INDEX($G$3:$G$121, MATCH(C3, $H$3:$H$121, 0)), "غير موجود") 'أو =XLOOKUP(C3, $H$3:$H$121, $G$3:$G$121, "غير موجود") بالأكواد Option Explicit Sub UpdateOrder() Dim WS As Worksheet, lastRow As Long, i As Long Dim Client As String, tmp As Variant Set WS = Sheets("خط السير") lastRow = 120 Application.ScreenUpdating = False WS.Range("b3:b" & lastRow).ClearContents For i = 3 To lastRow Client = WS.Cells(i, "C").Value If Client <> "" Then tmp = Application.Match(Client, WS.Range("H3:H" & lastRow), 0) If Not IsError(tmp) Then WS.Cells(i, "B").Value = WS.Cells(tmp + 2, "G").Value Else WS.Cells(i, "B").Value = "غير موجود" End If End If Next i Application.ScreenUpdating = True End Sub خط السير.rar

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Sub TaxCivil() Dim Irow&, lastRow&, lastCol&, i&, j&, k&, WS As Worksheet, dest As Worksheet, tmp As Double, _ OnRng As Variant, r As Variant, headers As Variant, n As Double, civil As String Set WS = Sheets("المعلومات") Set dest = Sheets("الموظفين") Application.ScreenUpdating = False Irow = dest.Cells(dest.Rows.Count, 3).End(xlUp).Row lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row lastCol = WS.Cells(2, WS.Columns.Count).End(xlToLeft).Column OnRng = dest.Range("A2:E" & Irow).Value r = WS.Range(WS.Cells(3, 1), WS.Cells(lastRow, lastCol)).Value headers = WS.Range(WS.Cells(2, 3), WS.Cells(2, lastCol)).Value dest.Range("E2:E" & Irow).ClearContents For i = 1 To UBound(OnRng, 1) n = OnRng(i, 3): civil = OnRng(i, 4) tmp = 0 If n = 0 Or Trim(civil) = "" Then GoTo SkipRow For j = 1 To UBound(r, 1) If n >= r(j, 1) And n <= r(j, 2) Then For k = 1 To UBound(headers, 2) If headers(1, k) = civil Then tmp = r(j, k + 2) Exit For End If Next k Exit For End If Next j OnRng(i, 5) = IIf(tmp > 0, tmp, "غير محدد") SkipRow: Next i dest.Range("A2").Resize(UBound(OnRng, 1), 5).Value = OnRng Application.ScreenUpdating = True End Sub ضريبة.xlsb

اخي لقد تم الاعتماد على الأعمدة المحددة في الكود الخاص بك Call Cnt(Sh1, WS, ling, Array(16, 4, 14, 9, 10)) Call Cnt(Sh2, WS, ling, Array(19, 4, 17, 9, 10, 11)) على العموم بعد تعديلها بما جاء في اخر مشاركة لك هده هي نتيجة كارت الصنف 121 لاحظ الصورة المرفقة ادا كان هدا هو المطلوب اخبرني بدالك

أعتقد أن سبب التأخير في الرد هو صعوبة فهم طلبك بالطريقة التي تم طرحه بها صراحة هذه النقطة لم أستوعبها تماما هل يمكنك توضيحها بشكل أبسط أو إرفاق عينة من النتائج المتوقعة بشكل أكثر دقة حتى نتمكن من مساعدتك بشكل أفضل؟ قم بتجربة هذا الكود أولا لجلب البيانات وعند التحقق من صحتها يمكنك توضيح التعديل المطلوب بشكل أدق وسوف نكون سعداء بمساعدتك لتحقيق النتائج الصحيحة Dim tmp As Variant Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, Items As Worksheet Dim Clé As Range, OnRng As Range, LastRow As Long, ling As Variant With ThisWorkbook Set WS = .Sheets("بطاقة صنف") Set Sh1 = .Sheets("اضافة") Set Sh2 = .Sheets("الصرف") Set Items = .Sheets("الأصناف") End With Set Clé = Me.Range("I3") If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Set OnRng = WS.Range("B6:I" & WS.Rows.Count) LastRow = Items.Cells(Items.Rows.Count, 1).End(xlUp).Row Clé.Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & LastRow & ",2,0),"""")" Clé.Value = Clé.Value ling = Me.Range("I3").Value If ling <> tmp Then tmp = ling If IsEmpty(ling) Or ling = "" Then OnRng.ClearContents GoTo AppTrue End If OnRng.ClearContents Call Cnt(Sh1, WS, ling, Array(16, 4, 14, 9, 10)) Call Cnt(Sh2, WS, ling, Array(19, 4, 17, 9, 10, 11)) If WorksheetFunction.CountA(WS.Range("B6:B" & WS.Rows.Count)) = 0 Then OnRng.ClearContents End If End If AppTrue: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End If End Sub '====================================== Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _ ByVal temp As Variant, ByVal ColArr As Variant) Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range LastRow = dest.Cells(dest.Rows.Count, 7).End(xlUp).Row For i = 3 To LastRow With dest If Not IsEmpty(.Cells(i, 7).Value) And Not IsError(.Cells(i, 7).Value) Then If .Cells(i, 7).Value = temp Then x = WorksheetFunction.CountA(tbl.Range("B6:B1000")) For n = LBound(ColArr) To UBound(ColArr) Set Cel = tbl.Cells(6 + x, 2 + n - LBound(ColArr)) Cel.Value = .Cells(i, ColArr(n)).Value Next n End If End If End With Next i End Sub مخازن 2024مكرو V2.xlsm

إليك الكود بعد تعديله Public Sub FilterAndCopy() Const tmpCol As String = "BC" Dim OnRng As Range, i As Long, n As Long, r As Long Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet Set WS = Sheets("اجمالي4") Set Sh1 = Sheets("بنون ناجحون") Set Sh2 = Sheets("بنات ناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A5:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With n = 7: r = 7 For i = 1 To OnRng.Rows.Count + 1 If InStr(1, WS.Cells(i, tmpCol).Value, "ناجح", vbTextCompare) > 0 Then If WS.Cells(i, 9).Value = "ذكر" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh1.Range("A" & n) n = n + 1 ElseIf WS.Cells(i, 9).Value = "انثى" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh2.Range("A" & r) r = r + 1 End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته Public Sub FilterAndCopy() Dim OnRng As Range, n As Long, tmp As Long Dim WS As Worksheet: Set WS = Sheets("اجمالي4") Dim Sh1 As Worksheet: Set Sh1 = Sheets("بنون ناجحون") Dim Sh2 As Worksheet: Set Sh2 = Sheets("بنات ناجحون") tmp = 56 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A2:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With With OnRng n = WorksheetFunction.CountIfs(OnRng.Columns(9), "ذكر") If n <> 0 Then .AutoFilter Field:=9, Criteria1:="ذكر" .Offset(1, 0).Resize(.Rows.Count - 1, tmp).Copy Sh1.Range("A7") End If n = WorksheetFunction.CountIfs(OnRng.Columns(9), "انثى") If n <> 0 Then .AutoFilter Field:=9, Criteria1:="انثى" .Offset(1, 0).Resize(.Rows.Count - 1, tmp).Copy Sh2.Range("A7") End If .Parent.AutoFilterMode = False End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

نعم أخي يمكنك تعديل السطور الأخيرة من الكود Dim fichier As String ' قم بتحديد خلية الإسم بما يناسبك fichier = WS.Range("E30").Value filePath = pdfFolder & "\" & fichier & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me وبما أن ورقة Round 5 تتضمن إسم المستفيد على عمود c يمكنك استخدام هدا ليتم تسمية الملف ديناميكيا عند التنفيد مع مزيدا من التحقق Private Sub CommandButton2_Click() Dim r As Long, s As Long, t As Long, FolderName As String, pdfFolder As String, i As Integer Dim filePath As String, ID As String, Item As String, tmp As String, Chars As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) For r = s To t If Trim(dest.Range("B" & r + 2).Value) <> "" Then Exit For Next r If r > t Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات", vbExclamation: Exit Sub pdfFolder = ThisWorkbook.Path & "\الإيصالات" If Dir(pdfFolder, vbDirectory) = "" Then MkDir pdfFolder Chars = "\ / : * ? "" < > |" For r = s To t ID = Trim(dest.Range("B" & r + 2).Value) '(C)'جلب إسم المستفيد من عمود Item = Trim(dest.Range("C" & r + 2).Value) '(ID)' تجاهل حفظ الملف عند التحقق من عدم وجود إسم المستفيد أو رقم If ID = "" Or Item = "" Then GoTo Cnt tmp = Item For i = 1 To Len(Chars) tmp = Replace(tmp, Mid(Chars, i, 1), "") Next i filePath = pdfFolder & "\" & tmp & ".pdf" WS.[d4] = ID: WS.[U2] = ID On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Cnt: Next r MsgBox ": تم تصدير الملفات إلى مجلد" & pdfFolder, vbInformation Unload Me End Sub PTT 2024 v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب في Module1 ضع الأكواد التالية Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............ جرد المنتج_V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته دالة IF تحتاج إلى شروط واضحة وتنتظر تحديد ما يجب أن يتم في حال كان الشرط صحيحا أو خطأفي حالتك IF "" غير مكتمل لأنك لم تحدد ما يجب تنفيذه في حال كانت الشروط فارغة أو صحيحة إذا كنت تحاول استخدام دالة IF مع FILTER لتحديد قيمة فارغة مثلا عند عدم وجود نتائج في FILTER فيمكنك استخدام دالة IFERROR =IFERROR(FILTER(AP4:AT353, ISNUMBER(SEARCH(AF6, AQ4:AQ353))), "") مع التأكد من أن الفواصل في الصيغة تتناسب مع الاصدار الموجود لديك ; او ,

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Public Property Get WS() As Worksheet Set WS = Sheets("PTT") End Property Public Property Get dest() As Worksheet Set dest = Sheets("Round 5") End Property Private Sub CommandButton1_Click() Dim r As Long, s As Long, t As Long, tmp As Long, ID As String, n As Boolean If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then MsgBox "لا يوجد أي إيصالات للطباعة على قاعدة البيانات ", vbExclamation Exit Sub End If On Error Resume Next For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt WS.[d4] = ID WS.[U2] = ID Err.Clear WS.PrintOut If Err.Number <> 0 Then MsgBox "تم إلغاء طباعة الإيصالات", vbExclamation Exit Sub End If Cnt: Next r WS.[aa1] = s WS.[aa2] = t Unload Me End Sub '===================================== Private Sub CommandButton2_Click() Dim r As Long, tmp As Long, s As Long, t As Long, FolderName As String Dim filePath As String, ID As String, n As Boolean, pdfFolder As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات ", vbExclamation: Exit Sub FolderName = "الإيصالات" pdfFolder = ThisWorkbook.Path & "\" & FolderName If Dir(pdfFolder, vbDirectory) = "" Then On Error Resume Next MkDir pdfFolder If Err.Number <> 0 Then: Exit Sub On Error GoTo 0 End If For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt End If WS.[d4] = ID: WS.[U2] = ID filePath = pdfFolder & "\invoice_" & ID & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me End Sub PTT 2024 v2.xlsm

ولا يهمك أخي @محمد العراقى سنكون سعداء دائما بحصولك على النتائج المطلوبة يكفي تعديل هدا الجزء من الكود For j = LBound(DaysArr) To UBound(DaysArr) For i = 0 To 7 ' الحصص dest.Cells(Irow, i + 2).Value = WS.Cells(OnRng.Row, cnt + i).Value ' المواد If WS.Cells(OnRng.Row + 1, cnt + i).Value <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row + 1, cnt + i).Value End If Next i cnt = cnt + 8 Irow = Irow + 2 Next j اجر-V2.xls

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ماتقصده بما أنك فاهم الكود سأوضح فقط ما تم تعديله If Not OnRng Is Nothing Then arr = Array("السبت", "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") Irow = 10 cnt = 7 Application.ScreenUpdating = False 'افراغ البيانات السابقة dest.Range("b10:Q21").ClearContents ReDim dataArr(0 To UBound(arr), 0 To 7) For j = 0 To UBound(arr) For i = 0 To 7 dataArr(j, i) = WS.Cells(OnRng.Row, cnt + i).Value Next i cnt = cnt + 8 Next j For j = 0 To UBound(arr) For i = 0 To 7 ' نسخ بيانات اليوم dest.Cells(Irow, i + 2).Value = dataArr(j, i) If IsDate(dest.Cells(Irow, i + 2).Value) Then dest.Cells(Irow, i + 2).NumberFormat = "@" End If ' اظافة اسم المادة في الصف الموالي If dataArr(j, i) <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row, 3).Value End If Next i Irow = Irow + 2 Next j '========== جلب المعلومات الإضافية ============ ' الاسم الرباعي للمعلم' الرقـم القومي ' الفـصــول ' المـــادة' عـدد الحصص المنفذة Dim CellArr As Variant, ColArr As Variant CellArr = Array("E5", "O5", "C6", "H6", "Q6") ColArr = Array(2, 4, 5, 3, 6) For i = LBound(CellArr) To UBound(CellArr) dest.Range(CellArr(i)).Value = WS.Cells(OnRng.Row, ColArr(i)).Value Next i Else MsgBox "لم يتم العثور على تسلسل المعلم " & linge, vbExclamation End If بالتوفيق...... اجر.xls

يمكنك دمج الطريقتين مع بعض كما في الصورة ListBox1.ColumnCount = 12-V3.xlsm