محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك إضافة قاعدة بيانات لأسماء الفرق والشعارات الخاصة بها في ورقة جديدة وتسميتها مثلا Logos واستخدام الكود التالي في حدث ورقة GroupA لتغيير الشعار تلقائيا بناء على التغيير في النتيجة عندما يتم نقل إسم الفريق في الورقة (أي تغيير موضع الخلية) سيتحرك الشعار إلى الموقع الجديد بشكل تلقائي كما في الصورة أدناه Option Explicit Private Sub Worksheet_Calculate() Dim tmp As Range, n As Shape, OnRng As Range Dim crWS As Worksheet: Set crWS = Me Dim dest As Worksheet: Set dest = Sheets("Logos") Application.ScreenUpdating = False For Each tmp In crWS.Range("J14:J" & crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row) If tmp.Value <> "" Then For Each n In crWS.Shapes If n.Type <> 8 And n.TopLeftCell.Address = tmp.Offset(0, -1).Address Then n.Delete Next n Set OnRng = dest.Range("A2:A" & dest.Cells(dest.Rows.Count, _ "A").End(xlUp).Row).Find(tmp.Value, LookAt:=xlWhole) If Not OnRng Is Nothing Then For Each n In dest.Shapes If n.TopLeftCell.Address = dest.Cells(OnRng.Row, _ dest.Range("A2:A" & dest.Cells(dest.Rows.Count, "A").End(xlUp).Row).Column + 1).Address Then n.Copy tmp.Offset(0, -1).Select ActiveSheet.Paste With Selection.ShapeRange .LockAspectRatio = msoFalse .Left = tmp.Offset(0, -1).Left + 4: .Top = tmp.Offset(0, -1).Top + 5 .Width = tmp.Offset(0, -1).Width - 8: .Height = tmp.Offset(0, -1).Height - 6 End With Selection.ShapeRange(1).Select Selection.ShapeRange(1).TopLeftCell.Select End If Next n Else For Each n In crWS.Shapes If n.Type <> 8 And n.TopLeftCell.Address = tmp.Offset(0, -1).Address Then n.Delete Next n End If End If Next tmp Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تجريبة v2.xlsb

يجب أخي تعديل النطاق المرغوب داخل الكود مثلا With WS ' نطاق البيانات a = .Range("E7:O" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value ' عناوين رؤوس الأعمدة headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", _ "الصافي", "السعر", "القيمة", "متوسط سعر البرنيكة", "متوسط وزن البرنيكة") End With النطاق الهدف On Error Resume Next lastRow = dest.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:L" & lastRow) الزرع v4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Option Explicit Sub test() Dim WS As Worksheet, tbl As Long, tmp As Long, i As Long Dim n As String, Max As Long, ky As Boolean Max = 34 Set WS = Sheets("ورقة1") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error Resume Next tbl = WS.Columns("B:M").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = IIf(tbl = 0, 6, tbl) tbl = IIf(tbl > Max, Max, tbl) WS.Range("N6:N" & tbl).ClearContents For tmp = 6 To tbl n = "" ky = False For i = 2 To 13 If WS.Cells(tmp, i).Value <> "" Then n = IIf(n = "", WS.Cells(5, i).Text, n & " - " & WS.Cells(5, i).Text) If Not ky Then WS.Cells(tmp, 14).NumberFormat = WS.Cells(tmp, i).NumberFormat ky = True End If End If Next i WS.Cells(tmp, 14).Value = n Next tmp Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub DATA V1.xlsb

تفضل أخي Option Explicit Sub test() Dim i, j, tbl, k, lastRow As Long, rng As Range, c As Range, s As String Dim dic As Object, WS As Worksheet, dest As Worksheet Dim a, headers, result, colArr, tmp As Variant Set WS = Sheets("يومية المقاولين") With Application .ScreenUpdating = False .Calculation = xlCalculationManual Set dic = CreateObject("Scripting.Dictionary") With WS a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", _ "الفارغ", "الصافي", "السعر", "القيمة") End With colArr = Array(3, 4) ' المورد (G) و الصنف (H) For Each tmp In colArr dic.RemoveAll For i = 1 To UBound(a, 1) s = Trim(CStr(a(i, tmp))) If Len(s) > 0 And Not dic.exists(s) Then dic(s) = Empty s = Replace(s, "/", "_"): s = Replace(s, "\", "_") On Error Resume Next Set dest = Sheets(s) On Error GoTo 0 If dest Is Nothing Then Set dest = Sheets.Add(, Sheets(Sheets.Count)) dest.Name = s dest.DisplayRightToLeft = True dest.Rows("9").RowHeight = 20 Else dest.Range("A9:J" & dest.Rows.Count).Clear End If With dest.Range("A9:J9") .Value = headers: .Font.Bold = True: .Interior.Color = RGB(204, 255, 255) End With tbl = 0 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, tmp))) = s Then tbl = tbl + 1 Next j ReDim result(1 To tbl, 1 To UBound(a, 2)) tbl = 1 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, tmp))) = s Then For k = 1 To UBound(a, 2) result(tbl, k) = a(j, k) Next k tbl = tbl + 1 End If Next j dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Value = _ Evaluate("ROW(" & dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Address & ")-9") On Error Resume Next lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:J" & lastRow) With rng .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .Borders.LineStyle = xlNone: .ColumnWidth = 10 End With For Each c In rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next c End If Set dest = Nothing Next i Next tmp WS.Activate .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الزرع v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub test() Dim a As Variant, headers As Variant, result As Variant, dic As Object, WS As Worksheet, dest As Worksheet Dim i As Long, j As Long, s As String, rowCount As Long, k As Long, lastRow As Long, rng As Range, c As Range Set WS = Sheets("يومية المقاولين") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set dic = CreateObject("Scripting.Dictionary") With WS a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", "الصافي", "السعر", "القيمة") End With For i = 1 To UBound(a, 1) s = Trim(CStr(a(i, 3))) If Len(s) > 0 And Not dic.exists(s) Then dic(s) = Empty s = Replace(s, "/", "_"): s = Replace(s, "\", "_") On Error Resume Next Set dest = Sheets(s) On Error GoTo 0 If dest Is Nothing Then Set dest = Sheets.Add(, Sheets(Sheets.Count)) dest.Name = s dest.DisplayRightToLeft = True Else dest.Range("A9:J" & dest.Rows.Count).Clear End If With dest.Range("A9:J9") .Value = headers .Font.Bold = True .Interior.Color = RGB(204, 255, 255) End With rowCount = 0 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, 3))) = s Then rowCount = rowCount + 1 Next j ReDim result(1 To rowCount, 1 To UBound(a, 2)) rowCount = 1 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, 3))) = s Then For k = 1 To UBound(a, 2) result(rowCount, k) = a(j, k) Next k rowCount = rowCount + 1 End If Next j dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result With dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-9") End With On Error Resume Next lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:J" & lastRow) With rng .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Borders.LineStyle = xlNone .ColumnWidth = 10 End With For Each c In rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next c End If Set dest = Nothing Next i WS.Activate With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الزرع v2.xlsm

طلبك غير مفهوم أخي حاول توضيحه أكثر

=IF(SUMIFS(INDIRECT("Sheet1!$F$" & $J$2 & ":$F$" & $K$2), INDIRECT("Sheet1!$D$" & $J$2 & ":$D$" & $K$2), "<=" & $G3, INDIRECT("Sheet1!$C$" & $J$2 & ":$C$" & $K$2), ">=" & $F3,INDIRECT("Sheet1!$A$" & $J$2 & ":$A$" & $K$2), $B3) = 0, "", SUMIFS(INDIRECT("Sheet1!$F$" & $J$2 & ":$F$" & $K$2), INDIRECT("Sheet1!$D$" & $J$2 & ":$D$" & $K$2), "<=" & $G3, INDIRECT("Sheet1!$C$" & $J$2 & ":$C$" & $K$2), ">=" & $F3, INDIRECT("Sheet1!$A$" & $J$2 & ":$A$" & $K$2), $B3)) =IF(SUMIFS(INDIRECT("Sheet1!$G$" & $J$2 & ":$G$" & $K$2), INDIRECT("Sheet1!$D$" & $J$2 & ":$D$" & $K$2), "<=" & $G3, INDIRECT("Sheet1!$C$" & $J$2 & ":$C$" & $K$2), ">=" & $F3, INDIRECT("Sheet1!$A$" & $J$2 & ":$A$" & $K$2), $B3) = 0, "", SUMIFS(INDIRECT("Sheet1!$G$" & $J$2 & ":$G$" & $K$2),INDIRECT("Sheet1!$D$" & $J$2 & ":$D$" & $K$2), "<=" & $G3, INDIRECT("Sheet1!$C$" & $J$2 & ":$C$" & $K$2), ">=" & $F3, INDIRECT("Sheet1!$A$" & $J$2 & ":$A$" & $K$2), $B3)) Summary Expenses.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته بعد الظغط على زر الإظهار قم بسحب الصور

تفضل أخي test2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا مع سحب المعادلة للأسفل =IFERROR(INDEX(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2); MATCH(0;COUNTIF($B$1:B2; INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)) + IF(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2) = ""; 1; 0); 0)); "") في حالة إستخدامك لنسخة أوفيس حديثة =IFERROR(UNIQUE(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)); "")

وعليكم السلام ورحمة الله تعاى وبركاته لنفترض أن عنوان الخلية هو C3 =OR(AND(ISNUMBER(C3), C3>=0, C3<=10), C3="غ") Test.xlsx

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

وعليكم السلام ورحمة الله تعالى وبركاته رغم أنني ليس متأكدا من طلبك بسبب كثرة الأكواد التي قمت بإرفاقها بالنسبة لعمود F (اجمالى ك وق) لا يمكن جمع القيم مباشرة إذا كانت مخزنة كنص باستخدام الدالة TEXT أعتقد انه يمكنك تجاوز هذه المشكلة بتعديل الكود لجمع القيم العددية مباشرة دون الحاجة إلى الصيغة TEXT مع الاحتفاظ بالصيغ في الأعمدة الأخرى Option Explicit Sub Test() Dim WS As Worksheet, dest As Worksheet, dict As Object Dim Code, name, Unit As String Dim cartn, Price, tmp, ColF As Double Dim ColArr, col, key, ColHard As Variant Dim lastRow, i, Irow As Long Set WS = Sheets("Sheet3"): Set dest = Sheets("رصيد") lastRow = WS.Cells(Rows.Count, 7).End(xlUp).Row If lastRow < 2 Then Exit Sub ColHard = Array("كود الصنف", "اسم الصنف", "وحدة الصنف", "سعر الصنف", "عدد الكراتين", "إجمالي ك وق", "ك", "ق") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With dest.Range("A2:H" & dest.Rows.Count).ClearContents Application.ErrorCheckingOptions.BackgroundChecking = False Set dict = CreateObject("Scripting.Dictionary") Irow = 2 For i = 2 To lastRow Code = Trim(CStr(WS.Cells(i, 7).value)) name = Trim(WS.Cells(i, 6).value) Unit = Trim(WS.Cells(i, 4).value) Price = Val(WS.Cells(i, 5).value) cartn = Val(WS.Cells(i, 3).value) If Code <> "" Then If dict.Exists(Code) Then dict(Code)(3) = dict(Code)(3) + cartn Else dict.Add Code, Array(name, Unit, Price, cartn) End If End If Next i With dest .Range("A1:H1").value = ColHard For Each key In dict.Keys .Cells(Irow, 1).value = key .Cells(Irow, 2).Resize(1, 4).value = dict(key) .Cells(Irow, 7).Formula = "=INT(E" & Irow & "/C" & Irow & ")" .Cells(Irow, 8).Formula = "=MOD(E" & Irow & ",C" & Irow & ")" Irow = Irow + 1 Next key .Cells(Irow, 1).value = "المجموع الكلي" ColF = 0 For i = 2 To Irow - 1 If .Cells(i, 5).value <> 0 And .Cells(i, 3).value <> 0 Then tmp = Int(.Cells(i, 5).value / .Cells(i, 3).value) + (.Cells(i, 5).value Mod _ .Cells(i, 3).value) / .Cells(i, 3).value Else tmp = 0 End If .Cells(i, 6).value = Format(tmp, "0.0") ColF = ColF + tmp Next i .Cells(Irow, 6).value = Format(ColF, "0.0") ColArr = Array("E", "G", "H") For Each col In ColArr .Cells(Irow, col).Formula = "=SUM(" & col & "2:" & col & (Irow - 1) & ")" Next col End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With MsgBox "تمت العملية بنجاح", vbInformation End Sub اجمالى2 V1.xlsm

يمكنك إظافة السطور التالية لتحديد التنسيق الدي يناسبك Dim ColArr As Variant, col As Variant ColArr = Array("H", "I", "J", "K") For Each col In ColArr With dest.Range(col & "5:" & col & dest.Rows.Count) .NumberFormat = "dd/mm/yyyy" End With Next col العقود v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا 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

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