محمد هشام.

All.BOQ.xlsx

بالنسبة للتسلسل يمكنك استخدام الصيغة التالية مع سحبها للاسفل بعد حدف كود ترقيم الصفوف من حدث ورقة 1 =IF(C9>0,SUBTOTAL(3,$C$9:C9),"") اما بخصوص تنسيق اعمدة الروابط اظن انه من الافضل ربط الكود مع زر يمكنك استخدامه مثلا بعد الانتهاء من نسخ جميع الروابط على العمودين جرب هدا Function tmp(Cnt As String) As Boolean Dim Request As Object Dim rc As Variant On Error GoTo EndNow Set Request = CreateObject("WinHttp.WinHttpRequest.5.1") With Request .Open "GET", Cnt, False .Send rc = .StatusText End With Set Request = Nothing If rc = "OK" Then tmp = True Exit Function EndNow: End Function Sub add_Hyperlinks() Application.ScreenUpdating = False Set WS = Sheets("Sheet1") Dim c As Excel.Range, Cnt As String, r As Excel.Range Dim a As Range, b As Range, Rng As Range lr = WS.Columns("i:j").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = WS.Range("i9:i" & lr): Set b = WS.Range("j9:j" & lr): Set Rng = Union(a, b) For Each c In a If c > "" Then c.Select Debug.Print c.Value Cnt = Trim(CStr(c.Text)) If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=c, Address:=Cnt, TextToDisplay:="رابط اليوتيوب" End If Next c For Each r In b If r > "" Then r.Select Debug.Print r.Value Cnt = Trim(CStr(r.Text)) If Left(Cnt, 4) <> "http" Then Cnt = "http://" & Cnt If tmp(Cnt) Then WS.Hyperlinks.Add Anchor:=r, Address:=Cnt, TextToDisplay:="رابط الفيسبوك" End If Next r With Rng .Font.Color = RGB(0, 0, 255) .Font.Underline = xlUnderlineStyleNone .Font.Bold = True .Font.Name = "Calibri" .Font.Size = 16 End With Application.ScreenUpdating = True End Sub 14-7-2024 V2.xlsm

لقد سبق الاشارة الى انه يفضل اظافة باسوورد لمحرر الاكواد تفاديا لهدا Password 3698 فتح المصنف على اجهزة محددة.xlsm

WS.Copy Set NewWb = ActiveWorkbook ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value NewWb.SaveAs fname, FileFormat:=51 NewWb.Close False Set NewWb = Nothing

اخي @mahmoud nasr alhasany بما ان الكود يعطي نتائج صحيحة ومرضية بالنسبة لك لا حاجة لتغييره هناك ملاحظة بسيطة اظن انك لم تقرأ الكود جيدا يمكنك الاستغناء عن كود التهيئة Private Sub UserForm_Initialize() لقد تمت اظافة افراغ و تنسيق اعمدة الليست بوكس مسبقا على الكود لا حاجة لتكراره ما دمت ترغب باختصار الاكواد Private Sub CommandButton3_Click() Dim x() As Variant Set f = Sheets(1): x = Array("ListBox1", "ListBox2") 'تفريغ عناصر الليست بوكس For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i 'Code ...... ................... ' تحديد عدد وعرض الاعمدة على الليست بوكس For i = 0 To UBound(x) With Me.Controls(x(i)) .ColumnCount = 5: .ColumnWidths = "50;60;65;50;95" End With Next i End Sub '=================================================== Private Sub CommandButton1_Click() ' اضف هدا في اخر الكود ليتم الغاء تحديد العناصر بعد تنفيده 'Code....... ...... For s = 1 To 4 Me("OptionButton" & s).Value = False Next End Sub message for expiring items1 V5.xlsm

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

جرب هدا Private Sub CommandButton3_Click() Dim x() As Variant Set f = Sheets(1): x = Array("ListBox1", "ListBox2") For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i Set d = CreateObject("Scripting.Dictionary") Set arr = f.Range("A2:E" & f.[A65000].End(xlUp).Row): a = arr.Value Dim tmp(): ReDim tmp(1 To UBound(a)) For i = LBound(a) To UBound(a) c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5)) If OptionButton1 = True And c > Date And c <= (Date + 720) Or _ OptionButton2 = True And c > Date And c <= (Date + 90) Or _ OptionButton3 = True And c > Date And c <= (Date + 180) Or _ OptionButton4 = True And c > Date And c <= (Date + 360) Then n = n + 1: tmp(n) = i ReDim Preserve tmp(1 To n + 1) Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _ Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")"))) Me.ListBox1.RemoveItem n ElseIf c > 0 And c <= (Date) Then d(i) = Results End If Next n = d.Count If n > 0 And Me.OptionButton1 = True Or Me.OptionButton2 = True Or _ Me.OptionButton3 = True Or Me.OptionButton4 = True Then Dim cnt: cnt = Application.Transpose(d.items) ReDim Preserve cnt(1 To 5, 1 To n + 1) Me.ListBox2.List = Application.Transpose(cnt) Me.ListBox2.RemoveItem n End If For i = 0 To UBound(x) With Me.Controls(x(i)) .ColumnCount = 5: .ColumnWidths = "55;50;80;50;50" End With Next i End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي @mahmoud nasr alhasany Private Sub CommandButton1_Click() Dim x() As Variant Set f = Sheets(1) x = Array("ListBox1", "ListBox2") Set d = CreateObject("Scripting.Dictionary") Set arr = f.Range("A2:C" & f.[A65000].End(xlUp).Row): a = arr.Value Dim tmp(): ReDim tmp(1 To UBound(a)) For i = LBound(a) To UBound(a) c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3)) If c > Date + 6 And c < (Date + 30) Then n = n + 1: tmp(n) = i ReDim Preserve tmp(1 To n + 1) Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _ Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")"))) Me.ListBox1.RemoveItem n ElseIf c > 0 And c < (Date + 6) Then d(i) = Results End If Next n = d.Count If n > 0 Then Dim Cnt: Cnt = Application.Transpose(d.items) ReDim Preserve Cnt(1 To 3, 1 To n + 1) Me.ListBox2.List = Application.Transpose(Cnt) Me.ListBox2.RemoveItem n End If For i = 0 To UBound(x): Me.Controls(x(i)).ColumnCount = 3: Next i End Sub message for expiring items1 V2.xlsm

Sub IFNotBlank() Dim lr&, i&, a() a = [A116:K231].Value lr = Range("AM" & Rows.Count).End(xlUp).Row Dim tmp(): ReDim tmp(1 To UBound(a)) For i = LBound(a) To UBound(a) If a(i, 1) > 0 Then n = n + 1: tmp(n) = i Next ReDim Preserve tmp(1 To n) a = Application.Index(a, Application.Transpose(tmp), _ Application.Transpose(Evaluate("Row(2:" & UBound(a, 2) & ")"))) Range("AM" & lr + 1).Resize(UBound(a), UBound(a, 2)) = a End Sub في حالة إظافة الصيغ على طول عمود (A) قم بتعديل الكود ليتم تجاهلها If a(i, 1) > 0 And _ a(i, 1) <> HasFormula Then n = n + 1: tmp(n) = i

وعليكم السلام ورحمة الله تعالى وبركاته اولا اشكرك استاد فوزي على هده الكلمات الطيبة هدا شرف وفخر انوله منك ووفقنا الله واياكم لما يحب ويرضى تفضل اخي جرب هدا Option Explicit Sub Delete_tables() Dim ws As Worksheet Dim i As Long, lr As Long, r As Range, j As Long Set ws = Worksheets("كشف الطباعة") Application.ScreenUpdating = False Set r = [H1] With ws lr = .Cells(.Rows.Count, "a").End(xlUp).Row j = r * 35 For i = j To lr If Range("a" & i) > j Then .Range(ws.Cells(j, "A"), .Cells(lr, "E")).Clear End If Next i End With Application.ScreenUpdating = True End Sub حذف الجداول v2.xlsm

Private Sub PDFConvertor_Click() Dim f As Worksheet: Set f = Sheets("Sheet5") Dim fname As String, filePath As String, folderName As String Dim sMsg As String, xname As String fname = f.[E1] folderName = "PDF ملفات" filePath = ThisWorkbook.Path & "\" & folderName xname = " من " & Format(f.[b1], "dd-mm-yyyy") & " " & _ "إلى " & " " & Format(f.[b2], "dd-mm-yyyy") Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير بصيغة", vbYesNo, fname) If Msg <> vbYes Then Exit Sub 'Call Main If Dir(filePath, vbDirectory) = "" Then MkDir filePath Set Rng = f.Range("A1").CurrentRegion f.PageSetup.PrintArea = Rng.Address f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=filePath & "\" & fname & xname & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False f.PageSetup.PrintArea = "" Application.ScreenUpdating = True MsgBox " تم حفظ الملف بنجاح " & vbCrLf & vbCrLf & xname, vbInformation, "PDF" End Sub '********************************** Private Sub Save_Excel_Click() Dim sh As Worksheet, NewWb As Workbook Dim folderName As Variant, FileName As String, fname As String Set sh = ThisWorkbook.Sheets("Sheet5") fname = sh.[E1] folderName = "ملفات Excel" filePath = ThisWorkbook.Path & "\" & folderName With Application .DisplayAlerts = False .ScreenUpdating = False sh.Copy Set NewWb = ActiveWorkbook: Set n = NewWb.Sheets(1) n.Name = fname n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete If Dir(filePath, vbDirectory) = "" Then MkDir filePath NewWb.SaveAs FileName:=filePath & "\" & fname & ".xlsx", FileFormat:=51 NewWb.Close False Set NewWb = Nothing .DisplayAlerts = True .ScreenUpdating = True MsgBox " تم حفظ الملف بنجاح ", vbInformation, "Excel" End With End Sub '************************************************** Private Sub WordView_Click() Dim lr&, tmp As Word.Document, n As Word.Application Dim WS As Worksheet: Set WS = Sheets("Sheet5") lr = WS.Range("A:A").Find("*", _ searchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set n = CreateObject("word.application") n.Visible = True: Const Cnt As Long = 1 xname = "Word ملفات" Patch = ThisWorkbook.Path & "\" & xname fname = WS.[E1] xdate = " من " & Format(WS.[b1], "dd-mm-yyyy") & " " & _ "إلى " & " " & Format(WS.[b2], "dd-mm-yyyy") Application.ScreenUpdating = False With WS.Range("A" & Cnt & ":H" & lr).Copy Set tmp = n.Documents.Add n.Selection.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False Application.CutCopyMode = False n.ActiveDocument.PageSetup.Orientation = wdOrientLandscape n.ActiveDocument.PageSetup.PaperSize = WdPaperSize.wdPaperA3 If Dir(Patch, vbDirectory) = "" Then MkDir Patch tmp.SaveAs Patch & "\" & fname & xdate & ".docx" tmp.Close Set tmp = Nothing n.Quit Set n = Nothing End With Application.ScreenUpdating = True MsgBox " تم حفظ الملف بنجاح " & _ vbCrLf & vbCrLf & xdate, vbInformation, "Word" End Sub كرت الصنف 2024 V2.xlsm

من المفروض ان تقوم بتصميم ملفك بالشكل المطلوب وارفاقه بدل رفع الصورة لهدا ساقتصر انا كدالك على ارفاق صورة بعد اظافة الجدول على عينة من البيانات وتنسيقه استخدم ما يلي Private Sub Image1_Click() Set f2 = Sheets("Sheet5") Application.ScreenUpdating = False f2.[A4:H10000].ClearContents r1 = TextBox1.Value: r2 = TextBox2.Value: r3 = TextBox3.Value: r4 = ComboBox1.Value: r5 = ComboBox2.Value hrd1 = Array("من تاريخ :", r1, " ", "اسم المخزن :", r4, "رصيداول مدة :") hrd2 = Array("الى تاريخ :", r2, " ", "اسم الصنف :", r5, r3) Titres = Array("رقم المستند", "التاريخ", "نوع الحركة", "اسم المخزن", "اسم الصنف", "شراء", "بيع", "الرصيد") f2.[A1].Resize(1, 6) = hrd1 f2.[A2].Resize(1, 6) = hrd2 f2.[A3].Resize(1, 8) = Titres a = Me.ListBox1.List f2.[A4].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a Unload Me Set Rng = f2.Range("A1").CurrentRegion f2.PageSetup.PrintArea = Rng.Address f2.PrintPreview End Sub

اولا حاول وضع الكود في Module 2) النطاق ("Idate") غير موجود عندك على الملف ممكن تشرح لي ما تحاول فعله ؟

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub UserForm_Initialize() Set f = Sheets("التقرير") Set Rng = f.Range("A3:j" & f.[A65000].End(xlUp).Row) wsData = Rng.Value For i = LBound(wsData) To UBound(wsData): wsData(i, 5) = Format(wsData(i, 5), "0.00"): Next i For i = 1 To UBound(wsData): wsData(i, 6) = Format(wsData(i, 6), "0.00"): Next i 'Code............ '''''''''''' End Sub

ادن اخي الكريم يمكنك الابداع في ظبط التنسيقات المرغوبة وان شاء الله سنحاول مساعدتك في اظافتها لوقة الطباعة بعد كل استعلام بطريقة ما

تمام ادن ما هو التنسيق المتوقع

حاولت فهم ما تحاول فعله صراحة انت فقط تعقد الامور عليك بدل الاعتماد على التنسيقات على الليست بوكس يمكنك انشاء ورقة خاصة بالطباعة منسقة مسبقا بالشكل الدي تريد ولتكن مخفية مثلا وتقوم بالترحيل اليها مباشرة وطباعتها دون حدف التنسيقات كل مرة واعادة ارجاعها

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1") End Property Sub Sort_Category() Dim OneRng As Range Dim lr As Long lr = F.Cells(Rows.Count, "E").End(xlUp).Row Set OneRng = F.Range("A2:L" & lr) With OneRng .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo End With End Sub '***************************** Sub Filter_and_create_Sheets() Application.DisplayAlerts = False Application.ScreenUpdating = False F.[w1] = F.[E1] RngA = F.[A1].CurrentRegion.Rows.Count RngB = F.[A1].CurrentRegion.Columns.Count F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=F.[w1], Unique:=True For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row) F.[W2] = c.Value On Error Resume Next Sheets(CStr(c.Value)).Delete On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Set n = ActiveSheet n.Name = CStr(c.Value) n.DisplayRightToLeft = True F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1] For r = 1 To 12 n.Cells.EntireRow.AutoFit n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Next c F.Activate End Sub تقرير صف أول 2025.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SaveActiveSheetVBA() Dim WS As Worksheet, NewWb As Workbook Dim SPath As Variant, FileName As String, fname As String Set WS = ThisWorkbook.Sheets("Sheet1") ' تحديد ورقة العمل SPath = ThisWorkbook.Path & "\" ' مسار الملف FileName = "TEST" ' اسم الملف fname = SPath & FileName With Application .DisplayAlerts = False .ScreenUpdating = False .CopyObjectsWithCells = False WS.Copy Set NewWb = ActiveWorkbook NewWb.SaveAs fname, FileFormat:=51 NewWb.Close False Set NewWb = Nothing .DisplayAlerts = True .CopyObjectsWithCells = True .ScreenUpdating = True End With End Sub Copy another Workbook.xlsm

تم التعديل في المشاركة السابقة

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة مختلفة Sub CopyRow_Item() Dim i&, j&, n&, cnt&, r&, lr&, a As Boolean Dim arr() As Variant, rCrit As Variant, rng As Variant Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("قاعدة العملاء") cnt = 2 With WS If [N1] = Empty Then MsgBox "اصحى و اكتب التاريخ", vbExclamation: Exit Sub Application.ScreenUpdating = False lr = .Columns("b:k").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row a = True n = 0 rng = .Range("B2:K" & .Range("B" & Rows.Count).End(xlUp).Row).Value cnt = .Cells(.Rows.Count, "AM").End(xlUp).Row ReDim arr(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 6) <> "" Or rng(i, 7) <> "" Then a = False n = n + 1 For j = 1 To UBound(rng, 2) arr(n, j) = rng(i, j) Next j End If Next i If n > 0 Then .Range("AM" & cnt + 1).Resize(n, UBound(arr, 2)) = arr cnt = cnt + n For r = 2 To lr Union(.Range("F" & r).Resize(, 2), .Range("I" & r)).ClearContents Next r Application.Goto .Range("AM" & 2), True: [N1] = "" End If End With Application.ScreenUpdating = True If a Then MsgBox "الرجاء إظافـــة التحصيلات", vbExclamation Else MsgBox "الحمد لله - تم ترحيل التحصيلات بنجاح " & vbNewLine & _ " مستر إيهاب الاسوانى", 64 End If End Sub كود ترحيل V3.xlsm

وعليكم السلام ورحمة الله نعالى وبركاته =COUNTIFS(L6:L25;">="&O3;L6:L25;"<="&P3;G6:G25;3;K6:K25;N3;C6:C25;1) fawaz_2.xlsb

يمكنك وضع الكود التالي في Private Sub Workbook_Open Private Sub Workbook_Open() ' هنا اسماء الاجهزة المسموح للمصنف الاشتغال عليها If Environ("computername") <> "CFAMURAD" And Environ("computername") <> "Officena" Then 'عند عدم تحقق الشرط يتم اظهار الرسالة وغلق الملف Application.DisplayAlerts = False MsgBox " لا يمكنك تشغيل هدا المصنف على هدا الكمبيوتر " & _ vbLf & vbLf & " .......... المرجوا الاتصال", _ vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, "معلومات" ThisWorkbook.Close Application.DisplayAlerts = True End If End Sub يستحسن وضع باسوورد لمحرر الاكواد لكي لا يتم التلاعب بالملف فتح المصنف على اجهزة محددة.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Extract_The_differences() '================02/07/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Dim a(1), b, i&, arr&, n&, x&, lr&, dic As Object Set dic = CreateObject("Scripting.Dictionary") Dim srcWS As Worksheet: Set srcWS = Sheets("النتائج") rCrit = [{1,2,12,13,14,18}] ''<======= ' تحديد اعمدة المقارنة With Sheets("2023") With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18) a(0) = Application.Index(.Value, _ Evaluate("row(2:" & .Rows.Count & ")"), rCrit) End With End With For i = 1 To UBound(a(0), 1) dic(a(0)(i, 1)) = Array(i, Join(Application.Index(a(0), i, 0), Chr(2))) Next With Sheets("2022") With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18) a(1) = Application.Index(.Value, _ Evaluate("row(2:" & .Rows.Count & ")"), rCrit) End With End With ReDim b(1 To UBound(a(1), 1), 1 To UBound(a(1), 2) * 2 + 2) For i = 1 To UBound(a(1), 1) If dic.exists(a(1)(i, 1)) Then If dic(a(1)(i, 1))(1) <> Join(Application.Index(a(1), i, 0), Chr(2)) Then n = n + 1 For arr = 1 To UBound(a(1), 2) b(n, arr) = a(1)(i, arr) b(n, arr + UBound(b, 2) / 2) = a(0)(dic(a(1)(i, 1))(0), arr) If b(n, arr) <> b(n, arr + UBound(b, 2) / 2) Then b(n, UBound(b, 2)) = b(n, UBound(b, 2)) + 1 End If Next End If End If Next With srcWS Application.ScreenUpdating = False With .Rows("5:" & .Cells.SpecialCells(11).Row) .ClearContents: .Interior.ColorIndex = xlNone End With If n Then .[A5].Resize(n, UBound(b, 2)) = b '[تنسيق الاختلافات] On Error Resume Next With .Rows(4).SpecialCells(2).Areas(2) With .CurrentRegion.Resize(, .Columns.Count - 1) .FormatConditions.Delete .FormatConditions.Add 2, Formula1:="=" & .Cells(1).Address(0, 0) & "<>A4" .FormatConditions(1).Interior.Color = RGB(255, 204, 0): Set Rng = srcWS.[N5:N1000] On Error GoTo 0 End With End With End If End With Application.ScreenUpdating = True MsgBox Application.WorksheetFunction.Sum(Rng) & _ " " & ": عدد الاختلافات", vbInformation, " مقارنة 2022 / 2023 " End Sub مقارنة اعمدة معينة على ورقتين.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته استبدل =Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9+Feuil14!AJ9 بالمعادلة التالية =IF($B$6=1;Feuil14!C9;IF($B$6=2;SUM(Feuil14!C9+Feuil14!F9);IF($B$6=3;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9);IF($B$6=4;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9);IF($B$6=5;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9);IF($B$6=6;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9);IF($B$6=7;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9);IF($B$6=8;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9);IF($B$6=9;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9);IF($B$6=10;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9);IF($B$6=11;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9);IF($B$6=12;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9+Feuil14!AJ9))))))))))))) و =IF(Feuil1!$B$6>="1";SUMIFS(Feuil5!$E$11:$E$727;Feuil5!$B$11:$B$727;B9;Feuil5!$D$11:$D$727;$C$7);0) قم باستبدالها ب =SUMIFS(Feuil5!$E$10:$E$1000;Feuil5!$B$10:$B$1000;B9;Feuil5!$D$10:$D$1000;$C$7) جلب البيانات حسب 2 الشهر.rar