محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant: Set crWS = Sheets("العقود") arr = Array("العقود", "") ' في حالة وجود أوراق أخرى يجب الإحتفاظ بها قم بإظافتها هنا lastRow = crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row If lastRow < 5 Then: Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then: f.Delete End If Next f OnRng = crWS.Range("J4:J" & lastRow).Value For i = 1 To UBound(OnRng, 1) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") Next i crWS.Range("J4:J" & lastRow).Value = OnRng For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)): n = Month(sDate): x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, "J").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter .Range("J5:J" & lr).NumberFormat = "dd/mm/yyyy" End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function العقود v2.xlsb

أخي @بلانك فعلا الأكواد المقترحة لا تضع الخطوط وإنما لحدفها الاول لحدف الخطوط والثاني لحدف الاشكال لأنني لاحظت أنك إستخدمتها في ملفك المرفق في أول مشاركة هدا ما فهمت من طلبك الأخير رغم أن الكود الأول تم تزويدك به مسبقا جرب هدا Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub add_Underline() Dim lastRow As Long, OnRng As Variant, i As Long Dim Max As Integer Max = 20 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row OnRng = WS.Range("C3:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) With WS.Cells(i + 2, "C") If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then .Font.Underline = xlUnderlineStyleSingle .Font.Color = RGB(255, 0, 0) Else .Font.Underline = xlUnderlineStyleNone .Font.Color = RGB(0, 0, 0) End If End With Next i Application.EnableEvents = True Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub '============================= Sub Supprimer_lignes() Dim lastRow As Long, i As Long lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For i = 4 To lastRow WS.Cells(i, "C").Font.Underline = xlUnderlineStyleNone WS.Cells(i, "C").Font.Color = RGB(0, 0, 0) Next i End Sub كود لعمل خط تحت الدرجة الاقل V2.xlsb

كود لعمل خط تحت الدرجة الاقل..xlsb

Sub Supprimer_lignes() Dim lastRow As Long Dim WS As Worksheet :Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For i = 4 To lastRow WS.Cells(i, "C").Font.Underline = xlUnderlineStyleNone Next i End Sub إذا كنت ترغب في حذف الأشكال Sub Supprimer_Shapes() Dim WS As Worksheet, shp As Shape, lastRow As Long Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For Each shp In WS.Shapes If Not Intersect(shp.TopLeftCell, WS.Range("C4:C" & lastRow)) Is Nothing Then: shp.Delete Next shp End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, OnRng As Variant, i As Long Dim WS As Worksheet: Set WS = Me Dim Max As Integer Max = 20 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Not Intersect(Target, WS.Range("C3:C" & WS.Rows.Count)) Is Nothing Then lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row OnRng = WS.Range("C3:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) With WS.Cells(i + 2, "C") If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then .Font.Underline = xlUnderlineStyleSingle .Font.Color = RGB(255, 0, 0) Else .Font.Underline = xlUnderlineStyleNone .Font.Color = RGB(0, 0, 0) End If End With Next i End If Application.EnableEvents = True Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub كود لعمل خط تحت الدرجة الاقل.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اقتراحات من الممكن أن تستفيد منها سواءا للترتيب أو حفظ الملف Sub ExportToPDF() Dim endNum As Long, wb As Workbook, WS As Worksheet, i As Long Dim nFichier As String, chemin As String, r As String, n As Integer Set WS = Sheets("الشهادة") If IsEmpty(WS.Range("H2").Value) Then MsgBox "الرجاء تحديد إجمالي الشهادات", vbExclamation: Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False startNum = WS.[F2].Value: endNum = WS.[H2].Value Set wb = Workbooks.Add(xlWBATWorksheet) chemin = ThisWorkbook.Path & "\الشهادات\" If Len(Dir(chemin, vbDirectory)) = 0 Then MkDir chemin nFichier = WS.[B6].Value & "_" & WS.[B7].Value & ".pdf" r = chemin & nFichier If Len(Dir(r)) > 0 Then n = 1 Do r = chemin & WS.[B6].Value & "_" & WS.[B7].Value & "(" & n & ").pdf" n = n + 1 Loop Until Len(Dir(r)) = 0 End If For i = 1 To endNum WS.[F2].Value = i WS.Copy After:=wb.Worksheets(wb.Worksheets.Count) Next i WS.[F2].Value = 1 wb.Worksheets(1).Delete wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=r wb.Close False .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True End With MsgBox "تم تصدير الشهادات بنجاح في " & vbCrLf & vbCrLf & _ r, vbInformation, "تم حفظ الشهادات من " & startNum & " إلى " & endNum End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B7:S36")) Is Nothing Then Dim WS As Worksheet, i As Long, j As Long, n As Long, ky As Long, a() As Variant, tmp As Long, tbl As String Set WS = ActiveSheet Application.ScreenUpdating = False WS.Range("Y7:AA36").ClearContents For i = 7 To 36 If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _ Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1 Next i If tmp = 0 Then MsgBox "لا توجد بيانات", vbExclamation: Exit Sub ReDim a(1 To tmp, 1 To 3) tmp = 0 For i = 7 To 36 If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _ Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1 a(tmp, 1) = WS.Cells(i, "A").Value: a(tmp, 2) = WS.Cells(i, "B").Value: a(tmp, 3) = WS.Cells(i, "S").Value End If Next i For i = 1 To tmp - 1 For j = i + 1 To tmp If a(i, 3) < a(j, 3) Then r a(i, 1), a(j, 1): r a(i, 2), a(j, 2): r a(i, 3), a(j, 3) End If Next j Next i n = 1: ky = 1 WS.Cells(7, "Y").Value = 1: WS.Cells(7, "Z").Value = a(1, 2): WS.Cells(7, "AA").Value = "الأول" For i = 2 To tmp If a(i, 3) = a(i - 1, 3) Then ky = ky + 1 tbl = GetTex(n, ky) WS.Cells(i + 6, "AA").Value = tbl Else n = n + 1: ky = 1 tbl = GetTex(n, ky) WS.Cells(i + 6, "AA").Value = tbl End If WS.Cells(i + 6, "Y").Value = i: WS.Cells(i + 6, "Z").Value = a(i, 2) Next i Application.ScreenUpdating = True End If End Sub Sub r(ByRef a As Variant, ByRef b As Variant) Dim temp As Variant temp = a: a = b: b = temp End Sub Function GetTex(n As Long, ky As Long) As String GetTex = tmps(n) & IIf(ky > 1, " " & ky, "") End Function ترتيب التلاميذ تصاعديا V2.xlsm

جرب هدا Option Explicit Sub SortData() Dim WS As Worksheet: Set WS = Sheets("ورقة1") Dim lastRow As Long, tmp As Long, col As Variant Application.ScreenUpdating = False tmp = 0 On Error Resume Next tmp = WS.Columns("B").Find("الإجمالي", LookIn:=xlValues, LookAt:=xlWhole).Row On Error GoTo 0 If tmp > 0 Then lastRow = tmp - 1 WS.Range("B4:E" & lastRow).Sort Key1:=WS.Range("E4:E" & lastRow), Order1:=xlAscending, Header:=xlNo End If For Each col In Array("C", "D", "E") With WS.Cells(tmp, col) .Formula = "=SUM(" & col & "4:" & col & lastRow & ")": .Value = .Value End With Next col Application.ScreenUpdating = True End Sub فرز عملاء.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub kh_Color1() Dim Obj As Object, MyColor As Long, lr As Long, R As Long, txt As String Dim WS As Worksheet: Set WS = Sheets("قيود اليومية") Application.ScreenUpdating = False Set Obj = CreateObject("Scripting.Dictionary") MyColor = 900000 lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row WS.Range("A6:J" & lr).Interior.color = 800444 For R = 6 To lr txt = Trim(WS.Cells(R, "G")) If Len(txt) Then If Not Obj.Exists(txt) Then Obj.Add txt, MyColor MyColor = MyColor + 7000111 End If WS.Range(WS.Cells(R, "A"), WS.Cells(R, "J")).Interior.color = Obj(txt) Dim rColor As Long, gColor As Long, bColor As Long rColor = (Obj(txt) Mod 256) gColor = ((Obj(txt) \ 256) Mod 256) bColor = ((Obj(txt) \ 65536) Mod 256) If (rColor + gColor + bColor) / 3 < 128 Then WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(255, 255, 255) Else WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(0, 0, 0) End If End If Next R Set Obj = Nothing Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub ExportPDF_Circles() Dim WS As Worksheet, c As Range, MyRng As Range, V As Shape, pdfPath As String Dim x As Integer, r As Integer, lr As Long, wb As Workbook, i As Long, shp As Shape Set WS = Sheets("شهادةنصف") lr = WS.Range("U1").Value: r = 12: x = ActiveWindow.Zoom Application.ScreenUpdating = False: Application.EnableEvents = False: Application.DisplayAlerts = False Set wb = Workbooks.Add(xlWBATWorksheet): WS.Activate: Set MyRng = WS.Range("D13:P13,D30:P30,D47:P47") On Error Resume Next For Each shp In WS.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp On Error GoTo 0 For Each c In MyRng If c.Value <> "" And IsNumeric(WS.Cells(r, c.Column)) And _ Not IsEmpty(WS.Cells(r, c.Column)) And (c.Value < WS.Cells(r, c.Column) Or c.Value = "U" Or _ c.Value = "UU" Or c.Value = "غ") Then Set V = WS.Shapes.AddShape(msoShapeOval, c.Left + 1, c.Top + 1, c.Width - 2, c.Height - 2) V.Fill.Visible = msoFalse: V.Line.ForeColor.SchemeColor = 10: V.Line.Weight = 1.5 End If Next c For i = 1 To lr Step 3 WS.Range("H1").Value = i: WS.Copy After:=wb.Worksheets(wb.Worksheets.Count) Next i wb.Worksheets(1).Delete pdfPath = ThisWorkbook.Path & "\" & "الشهادات" & ".pdf" wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath wb.Close SaveChanges:=False Application.ScreenUpdating = True: Application.EnableEvents = True: Application.DisplayAlerts = True MsgBox "تم تصدير الشهادات إلى PDF" & vbCrLf & "المسار: " & pdfPath, vbInformation, "تم التصدير" End Sub

وعليكم السلام ورحمة الله تعالى وبركاته 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 يكفي فقط تعديل الأكواد الخاصة بالدخول لأوراق العمل (مسميات الأوراق) لتفادي ظهور رسالة الخطأ معك أو مراجعة الموضوع الأصلي للتوضيح يمكنك إرفاق الملف المرغوب دمجه ربما نستطيع مساعدتك