محمد هشام.

نعم اخي لاننا قمنا بعرض البيانات على الليست بوكس بداية من العمود رقم 2 (التاريخ) فمن الطبيعي عند الترحيل سيتم نسخ البيانات بداية من نفس العمود حاول اخي في المرة المقبلة تزويد طلبك بمعطيات كافية .تفاديا لاهدار الوقت والاشتغال على الملف اكثر من مرة .فمسالة التعديل ليست بالسهلة . على العموم تفضل اخي تم نعديل اكواد الترحيل وانشاء صفحات المقاولين مع مراعات جميع الاحتمالات الواردة على ما اظن في انتظارك بعد التجربة..........😁 كلمة المرور 0 مستخلصات الاعمال الجنوبية- V3.xlsm

تفضل اخي مستخلصات الاعمال الجنوبية- V2.xlsm

التغيير اخي سوف يكون هنا لكن يجب اولا اظافة الشرط الثاني ودالك باظافة كومبوبوكس جديدة وليكن اسمه T2 مثلا من If Rng(i, 4) >= Clé Then الى If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then وافراغ جميع الاكواد السابقة من على اليوزرفورم ونسخ الكود التالي Dim F, rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) rng = F.Value ' الاعمدة الظاهرة على الليست بوكس Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) ' تنسيق عمود المبلغ For i = LBound(rng) To UBound(rng): rng(i, 5) = Format(rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Col: j = UBound(Total) + 1 ' عمود الفلترة ColTri = 4 For i = LBound(rng) To UBound(rng) d(rng(i, ColTri)) = "" Next i ValTri = d.keys ' ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر P rng, 4, LBound(rng), UBound(rng) ' ترتيب تصاعدي لارقام الفواتير tri ValTri, LBound(ValTri), UBound(ValTri) ' جلب اصغر عدد Me.T1.List = ValTri: Me.T1 = ValTri(0) ' جلب اكبر عدد Me.T2.List = ValTri: Me.T2 = ValTri(UBound(ValTri)) MySum End Sub '***************** Sub Filtre() 'فلترة البيانات Dim Tbl(): n = 0: Clé = Val(Me.T1): Clé2 = Val(Me.T2) For i = 1 To UBound(rng) If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******combobox (T1 AND T2) 'ترتيب تصاعدي************* Sub tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '***ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر****** Sub P(a, V, gauc, droi) ref = a((gauc + droi) \ 2, V) g = gauc: d = droi Do Do While a(g, V) < ref: g = g + 1: Loop Do While ref < a(d, V): d = d - 1: Loop If g <= d Then For k = LBound(a, 2) To UBound(a, 2) temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp Next k g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call P(a, V, g, droi) If gauc < d Then Call P(a, V, gauc, d) End Sub '******************************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub '******************************* Private Sub T2_click() If Val(Me.T2) < Val(Me.T1) Then MsgBox "يجب أن يكون الحد الادنى لعدد الفواتير اكبر اويساوي " & Me.T1.Text, vbExclamation, "انتباه" Else Filtre End Sub Private Sub T1_click() If Val(Me.T1) > Val(Me.T2) Then MsgBox "يجب أن يكون الحد الاقصى لعدد الفواتير اصغر او يساوي " & Me.T2.Text, vbExclamation, "انتباه" Else Filtre End Sub اليك الملف للتجربة V3 تجربة (1).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub transfert() Dim desWS As Worksheet: Set desWS = Sheets("تجميع") Dim i As Byte, F As Variant Application.ScreenUpdating = False desWS.Range("a2:j" & Rows.Count).ClearContents For i = 1 To Worksheets.Count If UCase(Sheets(i).Name) <> desWS.Name Then With Sheets(i) F = .Range("A10:G10", .Range("a" & Rows.Count).End(xlUp)) desWS.[A65000].End(xlUp).Offset(2).Resize(UBound(F), 7) = F End With End If Next Application.ScreenUpdating = True End Sub في حالة الرغبة بتنسيق الجداول يمكنك اظافة الاسطر التالية اسفل الكود 'تنسيق الجداول '''*****تسطير***** With desWS lastrow = .Range("A:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = .Range("A2 :G" & lastrow) For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next '''****تمييز رؤوس الاعمدة*** Set j = .Range("a2:a" & lastrow) For Each r In j If r.Value = "ر.ت" Then _ If rng Is Nothing Then Set rng = r.Resize(1, 7) Else Set rng = Union(rng, r.Resize(1, 7)) Next If Not rng Is Nothing Then rng.Interior.Color = RGB(204, 204, 255): rng.Font.Bold = True End With ListEleve_20240320 V2.xlsm

ربما لم افهم طلبك جيدا عند معاينة العمود الثالث والرابع سنجد انه عند تواجد قيمة في صف معين العمود الاخر يكون فارغ ادن لم قمنا بتنفيد شرط عدم اظهار الفراغات لن تظهر معنا اي بيانات اظن انه يمكنك فلترة البيانات على حسب العمر بدون اظافة الاعمدة (من 20 الى 50) من خلال كومبوبكس لاصغر سن واخر لاكبر سن او توضيح الفكرة اكثر مع دكر الاعمدة المرغوب اظهارها على الليست بوكس

وعليكم السلام ورحمة الله تعالى وبركاته Dim F, Rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) Rng = F.Value Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) For i = LBound(Rng) To UBound(Rng): Rng(i, 5) = Format(Rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Array(5, 4, 3, 2, 1): j = UBound(Total) + 1 d("*") = "" For i = 1 To UBound(Rng) d(Rng(i, 4)) = "" Next i r = d.keys Me.T1.List = r: Me.T1 = "*" MySum End Sub '********************* Private Sub T1_click() Dim Tbl(): n = 0: Clé = Val(Me.T1) For i = 1 To UBound(Rng) If Rng(i, 4) >= Clé Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = Rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub V2 تجربة.xlsm

حاول أخي إرفاق ملف يتضمن بعض البيانات الوهمية للاشتغال عليه

Sub Delete_duplicate_condition() Dim I As Integer, Cpt As String Dim A As Integer, b As Integer Dim WS As Worksheet: Set WS = Sheets("Sheet1") lr = WS.Columns("B:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For I = lr To 2 Step -1 Cpt = Range("B" & I).Value A = Application.WorksheetFunction.MaxIfs(Range("E:E"), Range("B:B"), Cpt) b = Application.WorksheetFunction.MinIfs(Range("E:E"), Range("B:B"), Cpt) If Range("E" & I).Value <> A And Range("E" & I).Value <> b Then Range("B" & I & ":E" & I).Delete End If If Range("b" & I) = "" And Range("E" & I) = "" Then Range("B" & I & ":E" & I).Delete Next I End Sub

ادن ما هي النتيجة المتوقعة في حالة وجود نفس القيمة مكررة مرتين فقط او 3

وعليكم السلام ورحمة الله تعالى وبركاته بالنسبة لطلبك الاول يمكنك استخدام الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) IRow = Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row Dim r As Range: Set r = Range("B2:B" & IRow) Dim Arr() As Variant: Arr = r.Value2 Dim Cpt() As Variant: ReDim Cpt(1 To UBound(Arr), 1 To 1) On Error Resume Next Application.EnableEvents = False If Target.Column = 2 And Target.Row >= 2 Then Select Case LCase(Target.Value) Case Is <> "" With CreateObject("Scripting.DictionAry") For i = 1 To UBound(Arr) If Arr(i, 1) > 0 Then If Not .Exists(Arr(i, 1)) Then .Add Arr(i, 1), 1 Cpt(i, 1) = .Item(Arr(i, 1)) Else .Item(Arr(i, 1)) = .Item(Arr(i, 1)) + 1 Cpt(i, 1) = .Item(Arr(i, 1)) End If End If Next i r.Offset(, 3).Value2 = Cpt End With Case Is >= 0 Me.Cells(Target.Row, 5) = Empty End Select End If On Error GoTo 0 Application.EnableEvents = True End Sub بالنسبة للطلب الثاني ربما يجب عليك التوضيح اكثر هل تقصد عند تواجد اقل من 4 تكرارات يتم حدف اكبر قيمة فقط والاحتفاظ بالباقي او مادا حذف المكرر بشرط.xlsm

على شريط Excel، انتقل إلى علامة التبويب "الصيغ" > مجموعة الحساب، وانقر فوق الزر "خيارات الحساب" وحدد تلقائي (Automatic)

تفضل اليك الحلول التالية Sub ترحيل1() Dim Cpt As Long, Arr As Range, r As Range Dim a As Worksheet: Set a = Worksheets("Home"): Dim F As Worksheet: Set F = Worksheets("data") Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row With Application .Calculation = xlManual .ScreenUpdating = False b = Array(a.[B2], a.[B3]): c = a.[F5] d = Array(a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4]) '***لعدم الترحيل في حالة العثور على خلية فارغة*** 'Set Arr = Union(a.[B2:B5], a.[D2:D5], a.[F2:F5]) ' For Each r In Arr ' If IsEmpty(r.Value) Or r.Value = vbNullString Then ' MsgBox " المرجوا ملء بيانات " & r.Offset(0, -1).Value, vbExclamation, "إنتباه" ' Exit Sub ' End If ' Next r '************************************************ F.Cells(Cpt + 1, "A") = F.Cells(Cpt + 1, "A").Row - 2 F.Cells(Cpt, "B").Offset(1).Resize(, 2).Value = b F.Cells(Cpt, "E").Offset(1).Resize(, 9).Value = d F.Cells(Cpt, "O").Offset(1).Value = c .Calculation = xlAutomatic .ScreenUpdating = True End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub او Sub ترحيل2() Dim Cpt As Long Dim a As Worksheet: Set a = Sheets("Home"): Dim F As Worksheet: Set F = ThisWorkbook.Sheets("data") Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row + 1 With Application .Calculation = xlManual .ScreenUpdating = False Arr = Array(a.[B2], a.[B3], a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4], a.[F5]) For I = 0 To 11 If Arr(I) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(I).Offset(0, -1), vbExclamation, "إنتباه" Exit Sub End If Next F.Cells(Cpt, "A") = F.Cells(Cpt, "A").Row - 2 F.Cells(Cpt, "B").Value = a.[B2].Value: F.Cells(Cpt, "G").Value = a.[D2].Value F.Cells(Cpt, "C").Value = a.[B3].Value: F.Cells(Cpt, "H").Value = a.[D3].Value F.Cells(Cpt, "E").Value = a.[B4].Value: F.Cells(Cpt, "I").Value = a.[D4].Value F.Cells(Cpt, "F").Value = a.[B5].Value: F.Cells(Cpt, "J").Value = a.[D5].Value F.Cells(Cpt, "K").Value = a.[F2].Value: F.Cells(Cpt, "L").Value = a.[F3].Value F.Cells(Cpt, "M").Value = a.[F4].Value: F.Cells(Cpt, "O").Value = a.[F5].Value .Calculation = xlAutomatic .ScreenUpdating = True End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub 2024-3-15 ترحيل V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub ÊÑÍíá2() Dim Ws As Worksheet, F As Worksheet Dim X As Long, I As Long, Arr Set Ws = Sheets("Home"): Set F = Sheets("data") X = F.Cells(Rows.Count, 2).End(3).Row + 1 Application.ScreenUpdating = False Arr = Array("B2", "B3", "", "B4", "B5", "D2", "D3", "D4", "D5", "F2", "F3", "F4", "", "F5") For I = LBound(Arr) To UBound(Arr) If Arr(I) <> "" Then Arr(I) = Ws.Range(Arr(I)).Value Next I F.Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr F.Range("D3:D" & F.Range("B" & Rows.Count).End(3).Row) = "=($D$1-C3)/(365)" F.Range("N3:N" & F.Range("B" & Rows.Count).End(3).Row) = "=sum(k3+l3+m3)" F.Cells(X, 1) = F.Cells(X, 1).Row - 2 Application.ScreenUpdating = True End Sub او Sub ترحيل3() Dim Ws As Worksheet, F As Worksheet Dim X As Long, I As Long, Arr Set Ws = Sheets("Home"): Set F = Sheets("data") X = F.Cells(Rows.Count, 2).End(3).Row + 1 Application.ScreenUpdating = False Arr = Array("B2", "B3", "", "B4", "B5", "D2", "D3", "D4", "D5", "F2", "F3", "F4", "", "F5") For I = LBound(Arr) To UBound(Arr) If Arr(I) <> "" Then Arr(I) = Ws.Range(Arr(I)).Value Next I F.Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr With F.Range("A3:A" & F.Range("B" & Rows.Count).End(xlUp).Row) .Formula = "=IF(B3="""","""",IF(B3=""Name"",""Count"",N(A2)+1))" .Value = .Value With F.Range("D3:D" & F.Range("B" & Rows.Count).End(3).Row) .Formula = "=($D$1-C3)/(365)" .Value = .Value With F.Range("N3:N" & F.Range("B" & Rows.Count).End(3).Row) .Formula = "=sum(k3+l3+m3)" .Value = .Value End With End With End With Application.ScreenUpdating = True End Sub 2024-3-15 ترحيل بيانات 2.xlsm

حل اخر بالاكواد للبحث بالاسم او الرقم Private Sub TextBox1_Change() 'Sheet Segl clinic Dim a As Variant, b As Variant, clé As String Dim i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("Segl clinic") Dim F As Worksheet: Set F = Worksheets("search") If Me.TextBox1 = "" Then F.Range("b6:c" & Rows.Count).ClearContents Else On Error Resume Next a = WS.Range("F6", WS.Range("G" & Rows.Count).End(3)).Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) clé = "*" & F.Range("b3").Value & "*" For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) If LCase(a(i, j)) Like clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next F.Range("B6:C" & Rows.Count).ClearContents F.Range("b6").Resize(k, UBound(b, 2)).Value = b End If End Sub '********************** Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox1.Value = "" End If End Sub العيادة VBA.xlsm

العيادة.xlsx

جرب شيء مثل هدا =IF(OR(G13>0;H13>0);IF(OR(G13="اجتاز";H13="اجتاز");"جدير";"غير جدير");"") =IF(OR(G13<>"";H13<>"");IF(OR(G13="اجتاز";H13="اجتاز");"جدير";"غير جدير");"")

ربما هدا ما تقصده تجربة فرز الرواتب.xlsx

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

لقد ألقيت نظرة أكثر قليلاً على الكود الخاص بي ، وقمت بحساب عدد الملفات الموجودة بالفعل في المجلد. واكتشفت أنه إذا قمت بحذف أي من الإصدارات الأقدم، فسيخرج رقم الإصدار الجديد من المزامنة ولن يستخدم الرقم الأحدث. إذا كنت مهتم بتجربة إصدار آخر، فاستبدل هذا الرمز: ' ' تسلسل اسم الملف F = 0 Do While Cpt <> "" F = F + 1 Cpt = Dir Loop '(Excel بصيغة)' ' حفظ الملف في المسار التالي Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51 بهذا الكود: ' تسلسل اسم الملف Dim sVers As String Dim Réf As Long, F As Long Dim i As Long Do While Cpt <> "" sVers = Right(Left(Cpt, InStr(Cpt, ".xls") - 1), 4) Réf = 0 For i = Len(sVers) - 1 To 1 Step -1 If IsNumeric(Right(sVers, i)) Then Réf = Val(Right(sVers, i)) Exit For End If Next i If F < Réf Then F = Réf Cpt = Dir Loop '(Excel بصيغة)' ' حفظ الملف في المسار التالي Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا معرفة كم اسم موجود على رقم الهوية.xlsm

من الافضل جعل قيمة القائمة المنسدلة دور ثان فقط بدون له او لها واستخدام الكود التالي Sub Filter_and_copy_with_condition() Dim d, j Dim Search As Range, clé As String, IRow As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim F As Worksheet: Set F = Worksheets("saad") d = 9: j = 16: clé = "*" & F.[k1] IRow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With Application .Calculation = xlManual .ScreenUpdating = False If Len([k1].Value) = 0 Then: Exit Sub Set Search = WS.Range("U16:U" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub F.Range("C10:O" & Rows.Count).ClearContents Do Until IsEmpty(WS.Range("U" & j)) If WS.Range("U" & j) Like clé Then d = d + 1 F.Cells(d, 3).Value = WS.Cells(j, 3).Value F.Cells(d, 5).Value = WS.Cells(j, 5).Value F.Cells(d, 6).Value = WS.Cells(j, 6).Value F.Cells(d, 8).Value = WS.Cells(j, 10).Value F.Cells(d, 10).Value = WS.Cells(j, 12).Value F.Cells(d, 11).Value = WS.Cells(j, 13).Value F.Cells(d, 12).Value = WS.Cells(j, 16).Value F.Cells(d, 13).Value = WS.Cells(j, 17).Value F.Cells(d, 14).Value = WS.Cells(j, 18).Value F.Cells(d, 15).Value = WS.Cells(j, 21).Value End If j = j + 1 Loop .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub مصطفي V3.xlsb

تفضل ووافينا بالنتيجة Sub Filter_and_copy_with_condition() Dim Rng As Range, Search As Range Dim Col As Variant, a As Variant, MyRng As Variant, clé As Variant Dim i As Long, F As Long, Cpt As Long, Lastrow As Long, Irow As Long, ColStar As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim desWS As Worksheet: Set desWS = Worksheets("saad") clé = desWS.[k1]: ColStar = 10 'نطاق البيانات Lastrow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = WS.Range("C16:U" & Lastrow) Col = Rng.Value2 If Len([k1].Value) = 0 Then: Exit Sub With desWS Set Search = WS.Range("U16:U" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub Application.ScreenUpdating = False ' تخزين البيانات القديمة Irow = desWS.Columns("C:AT").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For Cpt = ColStar To Irow MyRng = desWS.Range("P10:AT" & Cpt).Value Next ' افراغ البيانات السابقة desWS.Range("C10:O" & Cpt).ClearContents ReDim a(1 To UBound(Col), 1 To UBound(Col, 2)) End With For i = 1 To UBound(Col) ' عند تحقق الشرط If Col(i, 19) = clé Then F = F + 1 a(F, 1) = Col(i, 1): a(F, 3) = Col(i, 3): a(F, 4) = Col(i, 4) a(F, 6) = Col(i, 8): a(F, 8) = Col(i, 10): a(F, 9) = Col(i, 11) a(F, 10) = Col(i, 14): a(F, 11) = Col(i, 15): a(F, 12) = Col(i, 16): a(F, 13) = Col(i, 19) End If Next i [C10].Resize(F, UBound(a, 2)).Value2 = a For Cpt = ColStar To Irow desWS.Range("P10:AT" & Cpt).Value = MyRng Next Application.ScreenUpdating = True End Sub وفي حدث ورقة saad ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("k1")) Is Nothing Then Call Filter_and_copy_with_condition End If End Sub مصطفي V2.xlsb

حل اخر مع اليوم الافتراضي لبداية الاسبوع بالنسبة لي . Sub GroupWeek_2() Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = Sheet1 Dim desWS As Worksheet: Set desWS = Sheet2 desWS.Cells.ClearContents: Cells.Interior.ColorIndex = xlNone ws.Range("A1:B1", ws.Range("a" & Rows.Count).End(xlUp)).Copy desWS.Range("A1") GroupByWeek desWS, "a2", "a", "اسبوع " End Sub Sub GroupByWeek( _ ByVal desWS As Worksheet, _ ByVal Clé As String, _ Optional ByVal GroupColumn As Variant = "a", _ Optional ByVal GroupBaseName As String = "اسبوع ") Dim f As Range, IRow As Long, lr& Dim Rng As String Dim minDate As Date, maxDate On Error Resume Next IRow = desWS.Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 minDate = Application.WorksheetFunction.Min(desWS.Range("A2:A" & IRow)) maxDate = Application.WorksheetFunction.Max(desWS.Range("A2:A" & IRow)) With Range("a2:a" & IRow) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Exit Sub End If End With Dim fCell As Range: Set fCell = desWS.Range(Clé) Dim lCell As Range Set lCell = fCell.Resize(desWS.Rows.Count - fCell.Row + 1) _ .Find("*", , xlFormulas, , , xlPrevious) If lCell Is Nothing Then Exit Sub Dim rCount As Long: rCount = lCell.Row - fCell.Row + 1 Dim crg As Range: Set crg = fCell.Resize(rCount) Dim Data As Variant If rCount = 1 Then ReDim Data(1 To 1, 1 To 1): Data = crg.Value Else Data = crg.Value End If ReDim Preserve Data(1 To rCount, 1 To 2) Dim CurrValue As Variant Dim CurrDate As Date Dim OldWeek As Long Dim NewWeek As Long Dim sr As Long Dim Cpt As Long For sr = 1 To rCount CurrValue = Data(sr, 1) If IsDate(CurrValue) Then NewWeek = Application.WeekNum(CurrValue) If NewWeek <> OldWeek Then Cpt = Cpt + 1 Set Data(Cpt, 1) = crg.Cells(sr) Data(Cpt, 2) = NewWeek OldWeek = NewWeek End If End If Next sr If Cpt = 0 Then Exit Sub For Cpt = Cpt To 1 Step -1 With Data(Cpt, 1) .EntireRow.Insert xlShiftDown .Offset(-1).EntireRow.Columns(GroupColumn).Value _ = GroupBaseName & Data(Cpt, 2) End With Next Cpt Dim ar As Range For Each ar In desWS.Range("b2:b" & desWS.Range("b" & Rows.Count).End(xlUp).Row + 1).SpecialCells(xlCellTypeConstants).Areas ar.Offset(-1).Resize(1).Value = WorksheetFunction.Sum(ar) Next lr = desWS.Columns("A:b").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 With desWS.Range("a2:a" & lr) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Rng = f.Address Do desWS.Range("a:b").Rows(f.Row).Interior.ColorIndex = 8 f.Interior.ColorIndex = 45 Set f = .FindNext(f) ' Loop While f.Address <> Rng End If End With Application.ScreenUpdating = True MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub مجموع كل أسبوع V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته مجرد فكرة ربما تناسبك Public Sub Split_Sheet_By_Weekly_Date_Ranges() Dim desWS As Worksheet, WS As Worksheet: Set WS = Sheet1 Dim lr As Long, minDate As Date, maxDate Dim WeekStar As Date, desWSName As String With Application .ScreenUpdating = False .DisplayAlerts = False For Each SH In Worksheets If SH.Name <> WS.Name Then Application.DisplayAlerts = False SH.Delete End If Next With WS lr = .Cells(.Rows.Count, "A").End(xlUp).Row minDate = Application.WorksheetFunction.Min(.Range("A2:A" & lr)) maxDate = Application.WorksheetFunction.Max(.Range("A2:A" & lr)) End With WeekStar = Date_Prev_Saturday(minDate) While WeekStar <= maxDate desWSName = Format(WeekStar, "dd-mm") & " To " & Format(WeekStar + 6, "dd-mm") With ActiveWorkbook Set desWS = Nothing On Error Resume Next Set desWS = .Worksheets(desWSName) On Error GoTo 0 If desWS Is Nothing Then Set desWS = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) desWS.Name = desWSName desWS.DisplayRightToLeft = True End If End With desWS.[A1:B1].Value = Array(WS.[A1].Value) desWS.[A2:B2].Value = Array(">=" & CLng(WeekStar), "<=" & CLng(WeekStar) + 6) WS.Range("A1:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=desWS.[A1:B2], CopyToRange:=desWS.[A4], Unique:=False desWS.Columns("A:B").AutoFit IRow = desWS.Cells(Rows.Count, "a").End(xlUp).Row + 1 With desWS.Range("A2:B" & IRow) .Cells(IRow - 1, "b").Formula = "=SUM(b5:b" & IRow - 1 & ")": .Cells(IRow - 1, "a").Value = "المجموع" .HorizontalAlignment = xlCenter .Value = .Value With Range("A" & IRow & ":B" & IRow).Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End With desWS.Rows("1:3").Delete Shift:=xlUp If desWS.[A3] = "" Then desWS.Delete WeekStar = WeekStar + 7 Wend WS.Activate DisplayAlerts = True .ScreenUpdating = True End With MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub 'Given a date, return the date of the preceding Saturday, or the date itself if it is a Saturday Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function مجموع كل أسبوع على حدة.xlsm

تفضل اخي Sub SaveFile_Excel() Dim wb As Workbook, desWS As Worksheet Set wb = ThisWorkbook: Set desWS = wb.Sheets("الفاتورة ") Dim a(1 To 3) As String Dim shape As shape: Dim rng As Range 'اسم الملف a(1) = desWS.[D3].Value With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next 'اسم مجلد الحفظ قم بتعديله بما يناسبك a(2) = "Excel فواتير المبيعات" '***********'لحفظ الملف في نفس مسار المصنف الرئيسي********* ' a(3) = Application.ActiveWorkbook.Path & "\" & a(2) '*************لحفظ الملف في بارتيشن من اختيارك************* ' قم بتحديد اسم البارتيشن الخاصة بك a(3) = "D:\" & a(2) ' انشاء المجلد في حالة عدم العثور عليه If Dir(a(3), vbDirectory) = "" Then MkDir a(3) Cpt = Dir(a(3) & "\" & a(1) & "*") desWS.Copy Set rng = [B1:F22] With rng .Value = .Value: .Validation.Delete For Each shape In ActiveSheet.Shapes shape.Delete Next End With ' تسلسل اسم الملف F = 0 Do While Cpt <> "" F = F + 1 Cpt = Dir Loop '(Excel بصيغة)' ' حفظ الملف في المسار التالي Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51 ' غلق المصنف ActiveWorkbook.Close DisplayAlerts = True .ScreenUpdating = True End With MsgBox "تم نسخ ملف " & " " & a(1) & " " & " بنجاح" & vbLf & vbLf & a(3) & _ "", vbInformation, "ملف رقم :" & " " & F + 1 End Sub لحفظ الملف بصيغة PDF قم بتعديل هدا السطر '(PDF بصيغة)' Application.ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=a(3) & "\" & a(1) & "_" & F + 1 حسابات احمد Excel & PDF.xlsm