محمد هشام.

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

=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

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

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