محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a() As Variant, ColArr As Variant, CelArr As Variant, txt As String, i As Integer, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("النموذج النهائي") Set OnRng = Me.Range("A" & Target.Row & ":AC" & Target.Row) txt = "مؤقت لمدة" If Not Intersect(Target, Me.Range("AD:AD")) Is Nothing And Me.Cells(Target.Row, "AD").Value <> "" Then If InStr(Me.Cells(Target.Row, "AD").Value, "ترحيل") > 0 Then If Application.CountA(OnRng) = 0 Then: MsgBox "لا يوجد بيانات في الصف ", vbExclamation: Exit Sub ColArr = Array("i", "G", "d", "C", "O", "U", "F", "Z") CelArr = Array("L2", "C9", "E13", "G13", "C14", "C15", "C16", "J26") ReDim a(LBound(ColArr) To UBound(ColArr)) For i = LBound(ColArr) To UBound(ColArr): a(i) = Me.Cells(Target.Row, ColArr(i)).Value: Next i WS.[C21].Value = IIf(Me.Cells(Target.Row, "Q").Value <> "", txt & " (" & Me.Cells(Target.Row, "Q").Value & ") سنوات", "") WS.[C22].Value = IIf(IsDate(Me.Cells(Target.Row, "R").Value), Format(Me.Cells(Target.Row, "R").Value, "yyyy/mm/dd"), "") WS.[C23].Value = IIf(IsDate(Me.Cells(Target.Row, "S").Value), Format(Me.Cells(Target.Row, "S").Value, "yyyy/mm/dd"), "") Application.ScreenUpdating = False : Application.EnableEvents = False On Error GoTo SubApp For i = LBound(CelArr) To UBound(CelArr): WS.Range(CelArr(i)).Value = a(i): Next i SubApp: Application.ScreenUpdating = True: Application.EnableEvents = True End If End If End Sub طلب ترحيل.xls

هدا ليس لدي أي علاقة بطلبك السابق (وضع الشهادات في فولدر بجوار الملف الاصلي) يرجى فتح موضوع جديد بطلبك مع إرفاق ملف للإشتغال عليه

وعليكم السلام ورحمة الله نعالى وبركاته دالة IFS هي دالة موجودة في إصدارات Excel الحديثة ولكنها غير مدعومة في Excel 2019 يمكنك استخدام دوال أخرى مثل IF المتداخلة لتحقيق نفس الوظيفة على سبيل المثال =IF(A2="","",IF(A2<5,"ضعيف",IF(A2<10,"متوسط",IF(A2<15,"حسن","ممتاز")))) أو =IF(A2="","",CHOOSE(MATCH(A2,{0,5,10,15},1),"ضعيف","متوسط","حسن","ممتاز")) يمكنك تعديل هذه الصيغ لتشمل العديد من الشروط المتداخلة حسب حاجتك إذا كنت ترغب في محاكاة دالة IFS باستخدام VBA يمكننا كتابة دالة مخصصة تقوم بالتحقق من عدة شروط في تسلسل مشابه لدالة IFS في Module قم بلصق الكود التالي Function IFS_Formula(ParamArray tmp() As Variant) As Variant Dim i As Integer For i = LBound(tmp) To UBound(tmp) Step 2 If tmp(i) Then IFS_Formula = tmp(i + 1) Exit Function End If Next i IFS_Formula = CVErr(xlErrValue) End Function واستخدام الدالة التالية =IFS_Formula(A2="","",A2<5,"ضعيف",A2<10,"متوسط",A2<15,"حسن",A2>=15,"ممتاز") في حالة لديك حاجة مستمرة لاستخدام دالة IFS فإن الحل الأكثر فعالية سيكون الترقية إلى Excel 2021 رابط التحميل https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file حيث تكون هذه الدالة مدعومة بشكل كامل بالتوفيق............. TEST-IFS.xlsb

هل ممكن ارفاق عينة للنتائج المتوقعة لمزيدا من التوضيح ؟

وعليكم السلام وحمة الله تعالى وبركاته يمكنك تعديله بما يناسبك Option Explicit Sub sav_PDFall() ActiveSheet.Unprotect Password:="saaa" Dim i As Integer Dim folderPath As String folderPath = ThisWorkbook.Path & "\الشهادات" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If For i = 1 To Range("u1") Step 3 Range("h1") = i If i <= Range("u1") Then ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=folderPath & "\" & Range("H1").Value & ".pdf", Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Next i ActiveSheet.Protect Password:="saaa" End Sub

وعليكم السلام ورحمة الله تعالى وبركاته يجب أولا التأكد من عدم تعطيل وحدات الماكرو بسبب أمان الملفات أغلق الملف ثم انقر بزر الماوس الأيمن على خصائص <------ إلغاء الحظر (Unblock) أعد فتح الملف وحاول تشغيل الماكرو التالي Sub OECUE1() Dim WS As Worksheet Dim début As Integer, fin As Integer Set WS = Sheets("haneen") If Not IsNumeric(WS.[H2].Value) Or Not IsNumeric(WS.[U2].Value) Then Exit Sub début = WS.[H2].Value: fin = WS.[U2].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب في تنفيذ الطباعة؟", vbYesNo + vbExclamation, "التأكيد") = vbNo Then Exit Sub Application.ScreenUpdating = False Do While début <= fin WS.PrintOut Copies:=1, Collate:=True If début < fin Then WS.[H2].Value = début + 1 début = début + 1 Loop Application.ScreenUpdating = True End Sub الطباعة.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub CopyData() Dim lastRow&, tmp&, i&, Counter& Dim WS As Worksheet, OnRng As Variant Dim SrWS As Worksheet: Set SrWS = Sheets("ملخص") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual SrWS.Range("A5:F" & SrWS.Rows.Count).ClearContents tmp = 5: Counter = 1 For Each WS In ThisWorkbook.Worksheets If WS.Name <> SrWS.Name Then OnRng = WS.Range("A3:E" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row).Value For i = 1 To UBound(OnRng, 1) If OnRng(i, 1) <> "" Then SrWS.Range("A" & tmp).Value = "فرع " & Counter SrWS.Range("B" & tmp).Resize(1, UBound(OnRng, 2)).Value = Application.Index(OnRng, i, 0) tmp = tmp + 1 End If Next i Counter = Counter + 1 End If Next WS Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Book1 V1.xlsb

أعتقد أن طلبك غير واضح وقاعدة البيانات غير مكتملة يرجى إظافة بعض البيانات الوهمية على الملف مع عينة للنتائج المتوقعة على ورقة 1 [ يدويا ] وإن شاء الله سوف نحاول مساعدتك

إدا كنت قد إستوعبت طلبك بشكل صحيح ربما هدا سيوفي بالغرض Option Explicit Sub CreateDossiers() Dim a As Variant, lastRow As Long, i As Long, msg As String Dim Dossiers As String, Fld As String, Patch As String Dim nCarte As String, nEmploy As String, tyCont As String Dim tbl As Object, Fname As String, fCount As Integer Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1") Set tbl = CreateObject("Scripting.Dictionary") lastRow = ScrWS.Cells(ScrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub a = ScrWS.Range("B2:D" & lastRow).Value Dossiers = ThisWorkbook.Path & "\" Fld = Dossiers & "عقد ثابت\" Patch = Dossiers & "عقد مؤقت\" If Dir(Dossiers, vbDirectory) = "" Then MkDir Dossiers If Dir(Fld, vbDirectory) = "" Then MkDir Fld If Dir(Patch, vbDirectory) = "" Then MkDir Patch For i = 1 To UBound(a, 1) If Trim(a(i, 3)) = "ثابت" Then tbl(Trim(a(i, 1)) & " - " & Trim(a(i, 2))) = "ثابت" End If Next i fCount = 0 For i = 1 To UBound(a, 1) nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3)) If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then Fname = nCarte & " - " & nEmploy If tbl.Exists(Fname) Then If Dir(Fld & Fname, vbDirectory) = "" Then MkDir Fld & Fname fCount = fCount + 1 End If Else If Dir(Patch & Fname, vbDirectory) = "" Then MkDir Patch & Fname fCount = fCount + 1 End If End If End If Next i msg = IIf(fCount > 0, "تم إنشاء " & fCount & " من المجلدات بنجاح", "جميع المجلدات موجودة مسبقا") MsgBox msg, vbInformation End Sub عقود V2.xlsb

هدا ما يفعله الكود فعلا عند نطابق نفس اسم الموظف ونفس رقم البطاقة لاكن أعتقد انه هناك عدة احتمالات واردة في مسألة إنشاء المجلدات يجب توضيحها لنفترض ان البيانات بهدا الشكل ما هي المجلدات المفروض إنشائها ثايت = ؟ مؤقت = ؟

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub CreateDossiers() Dim a As Variant, lastRow As Long, i As Long Dim folderPath As String, Dossier As String, ky As String Dim nCarte As String, nEmploy As String, tyCont As String Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1") lastRow = ScrWS.Cells(ScrWS.Rows.Count, "b").End(xlUp).Row a = ScrWS.Range("B2:D" & lastRow).Value folderPath = ThisWorkbook.Path & "\" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath For i = 1 To UBound(a, 1) nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3)) If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then Dossier = folderPath & tyCont & "\" If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier ky = Dossier & nCarte & " - " & nEmploy & "\" If Dir(ky, vbDirectory) = "" Then MkDir ky End If Next i MsgBox "تم إنشاء المجلدات بنجاح", vbInformation End Sub عقود V1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته حاول دمج الأكواد السابقة في كود واحد لتتمكن من طباعة وصل معين أو عدة وصولات من إختيارك بالطريقة التالية Sub Choose_the_print() Dim tmp As Variant, arr As Variant, n As Range Dim OnRng As String, xInput As String, a(1 To 6) As String Dim WS As Worksheet: Set WS = Sheets("ورقة1") a(1) = "H2:L16": a(2) = "N2:R16": a(3) = "T2:X16": a(4) = "H18:L32": a(5) = "N18:R32": a(6) = "T18:X32" xInput = InputBox("يرجى إدخال أرقام الوصولات للطباعة" & vbCrLf & "مفصولة بفاصلة (-) مثل: 3-2-1", "إختيار الوصولات") If Trim(xInput) = "" Then: MsgBox "لم يتم إدخال أي أرقام يرجى المحاولة مرة أخرى", vbExclamation: Exit Sub tmp = Split(xInput, "-") For Each arr In tmp If IsNumeric(Trim(arr)) Then If Val(arr) >= 1 And Val(arr) <= 6 Then OnRng = a(Val(arr)) Set n = WS.Range(OnRng) n.PrintOut Copies:=1, Collate:=True Else MsgBox "رقم الوصل " & arr & " غير موجود يرجى التأكد", vbExclamation Exit Sub End If Else MsgBox "إدخال خاطئ " & arr, vbExclamation Exit Sub End If Next arr MsgBox "تمت الطباعة بنجاح", vbInformation End Sub مثال.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub SaveAsPDF11() Dim WS As Worksheet, CrWS As Worksheet Set WS = ActiveSheet: Set CrWS = Sheets("مشروع 1") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False WS.Range("B2:I47").FormatConditions.Delete WS.Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>" savePath = "d:\" & WS.Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf" WS.Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath CrWS.Range("B2:I47").Copy WS.Range("B2").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub CopyData() Dim ColArr() As Variant, Irow&, lr& Dim OnRng As Range, f As Worksheet Dim WS As Worksheet: Set WS = Sheets("ملخص") Application.ScreenUpdating = False WS.Range("A2:Q" & WS.Rows.Count).ClearContents For Each f In ThisWorkbook.Sheets If f.Name <> WS.Name Then Irow = f.Cells(f.Rows.Count, "D").End(xlUp).Row If Irow > 2 Then If WS.Cells(2, 1).Value = "" Then WS.Range("A2:Q2").Value = f.Range("A2:Q2").Value End If Set OnRng = f.Range("A3:Q" & Irow) ColArr = OnRng.Value lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 WS.Cells(lr, "A").Resize(UBound(ColArr, 1), UBound(ColArr, 2)).Value = ColArr End If End If Next f Application.ScreenUpdating = True End Sub Book1 v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته lr = Cells(Rows.Count, 2).End(3).Row تحديد رقم الصف الأخير في العمود B الذي يحتوي على بيانات End(3) هي اختصار للخاصية xlUp التي تعني التحرك صعودا في العمود حتى تصل إلى أول خلية تحتوي على بيانات x = الصف الذي يبدأ منه النطاق المحدد Set my_rg = Range("A" & x & ":A" & lr).SpecialCells(4) لتحديد الخلايا داخل نطاق معين و هو اختصار للخاصية xlCellTypeBlanks التي تعني الخلايا الفارغة إدن بعد تحديد صف بداية النطاق وليكن مثلا الصف 5 الكود Option Explicit Sub test() Dim lr As Long, x As Long, my_rg As Range On Error Resume Next lr = Cells(Rows.Count, 2).End(3).Row x = 5 Set my_rg = Range("A" & x & ":A" & lr).SpecialCells(4) If Not my_rg Is Nothing Then my_rg.EntireRow.Delete End If On Error GoTo 0 End Sub لنفترض ان اخر خلية في العمود B هي 100 إذا كان هناك خلايا فارغة في العمود A ضمن النطاق A5:A100 سيتم حذف الصفوف التي تحتوي على هذه الخلايا مع تجاهل الخلايا التي تتضمن قيم أو معادلات

اخي @هشام جمال الدين الملف المرفق عبارة عن شاشة دخول تتضمن تخويل صلاحية الدخول لاوراق معينة لمستخدم معين عبر تحديد دالك في ورقة صلاحيات باظافة عبارة نعم أو لا في الجدول التالي يمكنك اظافة ملفات أخرى للملف عادي سيتم تحديث أسمائها تلقائيا في عمود A بداية من الصف 6 دون مشاكل بما أنك حدفت جميع الأوراق السابقة والاحتفاظ فقط بالوقة 16 يكفي فقط تعديل الأكواد الخاصة بالدخول لأوراق العمل (مسميات الأوراق) لتفادي ظهور رسالة الخطأ معك أو مراجعة الموضوع الأصلي للتوضيح يمكنك إرفاق الملف المرغوب دمجه ربما نستطيع مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته حل اخر بإستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, i As Long, n As Long, tmp As Variant, a As Object If Intersect(Target, Me.Columns("A:B")) Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False On Error Resume Next lastRow = Me.Columns("A:B").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow < 2 Then GoTo CleanUp Me.Range("A2:A" & lastRow).ClearContents tmp = Me.Range("B2:B" & lastRow).Value: Set a = CreateObject("Scripting.Dictionary") For i = 1 To UBound(tmp) If Len(Trim(tmp(i, 1))) > 0 And Not a.exists(tmp(i, 1)) Then n = n + 1: a(tmp(i, 1)) = n: Me.Cells(i + 1, "A").Value = n End If Next i CleanUp: Application.ScreenUpdating = True Application.EnableEvents = True End Sub ترقيم بتجاوز المكرر.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub FindStagnantItems() Const stagnantPeriod As Integer = 90 Dim WS As Worksheet, dest As Worksheet, ShArr As Variant, Ky As Object Dim lastRow As Long, i As Long, d As Object, cate As Variant, Irow As Long Dim item As String, Store As String, Movement As Date, C As Variant ShArr = Array("مخزن الرئيسي", "فرع 1") Set d = CreateObject("Scripting.Dictionary"): Set Ky = CreateObject("Scripting.Dictionary") For Each C In ShArr On Error Resume Next Set WS = ThisWorkbook.Sheets(C) On Error GoTo 0 If WS Is Nothing Then MsgBox "خطأ في الوصول إلى الورقة: " & C, vbCritical: Exit Sub Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRow item = WS.Cells(i, 1).Value: Store = WS.Cells(i, 4).Value: Movement = WS.Cells(i, 3).Value If item <> "" And Store <> "" Then If IsDate(Movement) Then If DateDiff("d", Movement, Date) > stagnantPeriod Then If Not d.Exists(Store) Then d.Add Store, New Collection If Not n(d(Store), item) Then d(Store).Add item Ky(Store) = Ky(Store) + 1 End If End If End If Next i Next C On Error Resume Next: Set dest = Worksheets("أصناف راكدة"): On Error GoTo 0 If dest Is Nothing Then Set dest = Worksheets.Add: dest.Name = "أصناف راكدة" Else dest.Cells.ClearContents End If dest.[A1].Resize(1, 2) = Array("التصنيف", "عدد الأصناف الراكدة") Irow = 2 For Each cate In Ky.keys dest.Cells(Irow, 1).Value = cate dest.Cells(Irow, 2).Value = Ky(cate) Irow = Irow + 1 Next cate Application.ScreenUpdating = True MsgBox "تم إنشاء تقرير الأصناف الراكدة بنجاح", vbInformation End Sub Function n(col As Collection, val As String) As Boolean On Error Resume Next n = Not IsError(col(val)) End Function الاصناف الراكدة لكل مخزن.xlsm

يسعدنا أخي @محمد نوح أننا إستطعنا مساعدتك

أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط جرب هدا التعديل Option Explicit Private Const Clé As String = "1234" Public Property Get WS() As Worksheet Set WS = Sheets("Sheet1") End Property Sub ProtectSheet(xligne As Long) With WS .Unprotect Password:=Clé: .Cells.Locked = False .Range("A2:M" & xligne).FormulaHidden = True .Range("A2:M" & xligne).Locked = True: .Protect Password:=Clé End With End Sub Sub WSUnprotect() With WS .Unprotect Password:=Clé .Cells.Locked = False .Cells.FormulaHidden = False End With End Sub Sub Data_Protection() Dim xligne As Long If InputBox("أدخل كلمة المرور للمتابعة") <> Clé Then MsgBox "كلمة المرور غير صحيحة تم إلغاء العملية", vbCritical Exit Sub End If xligne = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If xligne < 1 Or xligne > WS.Rows.Count Then MsgBox "خطأ في الإدخال يرجى إدخال رقم صف صحيح", vbExclamation Exit Sub End If SetApp False ProtectSheet xligne SetApp True MsgBox "تم قفل الحسابات بنجاح لغاية الصف: " & xligne, vbInformation End Sub Sub Data_UnProtection() Dim PassProtect As String PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = Clé Then SetApp False: WSUnprotect: SetApp True MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation ElseIf PassProtect <> "" Then MsgBox "كلمة المرور غير صحيحة", vbCritical End If End Sub Private Sub SetApp(ByVal enable As Boolean) On Error GoTo xError Application.ScreenUpdating = enable Application.EnableEvents = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) Exit Sub xError: End Sub غلق المدى المحدد .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا في Module ضع الكود التالي Sub ColoriageDoublons() Dim WSarr As Variant, couleurs As Long, d As Object, _ s As Variant, OnRng As Range, lastRow As Long, a, i As Long WSarr = Array(1, 2, 3): couleurs = RGB(0, 204, 255) Set d = CreateObject("Scripting.Dictionary") For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = .Range("C4:C" & lastRow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then d(a(i, 1)) = d(a(i, 1)) + 1 Next i End With Next s For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set OnRng = .Range("C4:C" & lastRow) a = OnRng.Value For i = 1 To UBound(a, 1) OnRng.Cells(i).Interior.Color = IIf(a(i, 1) <> "" And d(a(i, 1)) > 1, couleurs, xlNone) Next i End With Next s End Sub وفي حدث ThisWorkbook Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim WSarr As Variant WSarr = Array("1", "2", "3") If Not Intersect(Target, Sh.Columns("C")) Is Nothing And Target.Row >= 4 Then Application.ScreenUpdating = False If Not IsError(Application.Match(Sh.Name, WSarr, 0)) Then Call ColoriageDoublons End If Application.ScreenUpdating = True End If End Sub تلوين الخلايا v2 المكررة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveAsPDF() Const Max As Long = 1000 Dim WS As Worksheet, Irow As Long, OnRng As Range Dim xPath As String, Dossier As String, Fichier As String Set WS = Sheets("Sheet1") Irow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If Irow > Max Then Irow = Max: Set OnRng = WS.Range("A2:Z" & Irow) If Application.WorksheetFunction.CountA(OnRng) = 0 Then Exit Sub WS.ResetAllPageBreaks With WS.PageSetup .PrintArea = OnRng.Address: .Orientation = xlPortrait: .PaperSize = xlPaperA4 .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False End With Dossier = ThisWorkbook.Path & "\ملفات PDF" If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier Fichier = Replace(WS.Range("AA1").Value, "/", "_") xPath = Dossier & "\" & Fichier & " " & Format(Now, "yyyy-mm-dd hh.mm") & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "" MsgBox "تم حفظ الملف بنجاح ", vbInformation End Sub Test-PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Book1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا حفظ الملفات في تفس مسار الملف Option Explicit Sub SAVE_PDF() Dim ScWS As Variant, Path As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" If Path = "\" Then Exit Sub For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub لإنشاء مجلد وحفظ الملفات بداخله Sub SAVE_PDF_Folder() Dim ScWS As Variant, Path As String, Dossier As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" Dossier = "ملفات PDF" If Path = "\" Then Exit Sub If Dir(Path & Dossier, vbDirectory) = "" Then MkDir Path & Dossier Path = Path & Dossier & "\" For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub Function ShExists(ByVal SheetName As String) As Boolean On Error Resume Next: ShExists = Not Sheets(SheetName) Is Nothing: On Error GoTo 0 End Function حفظ الملفات مستقلة بصيغة PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Transfer() Dim srcRange As Range, Lr As Long, destCols As Variant Dim WS As Worksheet, dest As Worksheet, i As Integer Dim a(1 To 1, 1 To 7) As Variant Set WS = ActiveSheet Set dest = Sheets("كشف الحساب") a(1, 1) = WS.[B6].Value: a(1, 2) = WS.[C6].Value: a(1, 3) = WS.[D6].Value a(1, 4) = WS.[E6].Value: a(1, 5) = WS.[G6].Value: a(1, 6) = WS.[H6].Value: a(1, 7) = WS.[I6].Value destCols = Array("C", "D", "E", "F", "H", "I", "J") Lr = dest.Cells(dest.Rows.Count, "D").End(xlUp).Row + 1 For i = 0 To 6 dest.Cells(Lr, destCols(i)).Value = a(1, i + 1) Next i End Sub """""""""""""""""""""""""""""""""""""""""""""""""""""""""" Sub testCopy() Dim i As Integer, ScrWS As Worksheet, btn As Object Dim Sh As Worksheet: Set Sh = Sheets("البون") Application.ScreenUpdating = False Application.DisplayAlerts = False Application.CutCopyMode = False For i = 1 To 15 On Error Resume Next Set ScrWS = ThisWorkbook.Sheets(Sh.Name & i) If Not ScrWS Is Nothing Then ScrWS.Delete Next i For i = 1 To 15 Sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set ScrWS = ActiveSheet ScrWS.Name = Sh.Name & i ScrWS.DisplayRightToLeft = True For Each btn In ScrWS.Buttons: btn.Delete: Next btn On Error GoTo 0 Set btn = ScrWS.Buttons.Add(400, 20, 60, 30): btn.OnAction = "Transfer": btn.Caption = "ترحيل" Next i Sh.Activate Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الايرادات والمصروفات.xlsm