محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته 
 لجلب اخر  تاريخ استلام 
=IFERROR(IF(NOT(ISBLANK(A2));LOOKUP(2;1/INDEX(البيانات!$B$2:$M$11;MATCH(A2;البيانات!$A$2:$A$11;0);0) ;البيانات!$B$1:$M$1);"");"لم يستلم") لجلب المبلغ الكلي
=IFERROR(SUM(INDEX(البيانات!$B$2:$M$11;MATCH(A2;البيانات!$A$2:$A$11;0);0));"") لجلب اخر قيمة مدخلة 
=IFERROR(LOOKUP(2;1/INDEX(البيانات!$B$2:$M$11;MATCH(الخلاصة!A2;البيانات!$A$2:$A$11;0);0);البيانات!B2:M2);"لم يستلم")  
 في حالة الرغبة باستخدام الاكواد 
 
 
Sub test() Dim lastrow As Long, lige As Long, lastcol As Long Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("الخلاصة") With Application .ScreenUpdating = False .Calculation = xlManual F = WS.Name lastrow = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastcol = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column Set A = WS.Range("B2:M" & lastrow): Set B = WS.Range("A2:A" & lastrow) Set C = WS.Range("B1", WS.Cells(1, lastcol)) lige = desWS.Range("A:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(IF(NOT(ISBLANK('" & desWS.Name & "'!A2)),LOOKUP(2,1/INDEX('" & F & "'!" & A.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0),'" & F & "'!" & C.Address & "),""""),""لم يستلم"")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IFERROR(SUM(INDEX('" & F & "'!" & A.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0)),"""")" .Value = .Value End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub بالتوفيق...........
التاريخ الاخير الذي استلم Formula.xlsx التاريخ الاخير الذي استلم VBA.xlsb

السبب هو الصفوف الفارغة الموجودة اسفل الجدول  
 حاول اعادة تسمية النطاق بالشكل التالي
=OFFSET(Produits!$N$2;;;COUNTA(Produits!$N:$N)-1) ووضع هدا الكود في موديول 
Sub Delete() Dim i As Long On Error Resume Next Application.ScreenUpdating = False With Worksheets("Produits").ListObjects("T_listrayon") For i = .ListRows.Count To 1 Step -1 If .ListRows(i).Range.Cells(1) = "" Then .ListRows(i).Delete End If Next i End With Application.ScreenUpdating = True End Sub  
 
Sub afformulaire() On Error Resume Next Call Delete Sheets("ACCUEIL").Activate: Formulaire.MultiPage1.Value = 0: Formulaire.Show modal End Sub  
Gest_magasin2.xlsm

قم باستبدالها الى
ws.Cells(ligne, 1) = Me.TextBox1.Text وفي كود التعديل 
f.Cells(LigneN_Row, 1) = Me.TextBox1 وفي عمود حالة الاجازة يمكنك تجربة المعادلة التالية   بدون الاعتماد على الخلية (1M)
 
 
=IF(ISBLANK(H3);"";IF(H3<TODAY();"باشر";"يتمتع"))  
عند كتابة الكود يأتي الاسم -تحديث1.xlsb

جرب هدا 
Sub PrintArea() Dim F As Worksheet: Set F = Sheet1 Cpt = 18: A = 1: B = 4: C = 1 With F .PageSetup.PrintArea = "" .PageSetup.PrintArea = Range("A1", Cells(46, Cpt)).Address: .PrintOut Copies:=A .PageSetup.PrintArea = Range("A47", Cells(96, Cpt)).Address: .PrintOut Copies:=B .PageSetup.PrintArea = Range("A97", Cells(150, Cpt)).Address: .PrintOut Copies:=C End With End Sub او يمكنك تحديد الصفحات وعدد مرات الطباعة بالاعتماد على ورقة اخرى خاصة بالاعدادات كما في المثال التالي 

Public Property Get Sh_Print() As Worksheet: Set Sh_Print = Sheet1 End Property Public Property Get F() As Worksheet: Set F = Sheet2 End Property Sub To_print() déleteRow TbPage = F.[Tb_MiseEnPage] NbMax = UBound(TbPage) Cpt = Application.InputBox(Prompt:=" المرجوا ادخال رقم الصفحة المرغوب طباعتها (من 0 الى " & NbMax & ")", Title:="طباعة", Type:=1) Cpt = Int(Cpt) If Cpt < 1 Then Exit Sub If Cpt > NbMax Then: MsgBox " اخر صفحة على الملف هي : " _ & NbMax _ & "", vbExclamation, "المرجوا التحقق من رقم الصفحة المرغوب طباعتها": Exit Sub With Sh_Print .PageSetup.PrintArea = "" For i = 1 To Cpt With .PageSetup On Error Resume Next .PrintArea = TbPage(i, 2) & ":" & TbPage(i, 3): Copies = TbPage(i, 4) If Copies < 1 Then Copies = 1 .FitToPagesWide = 1 .FitToPagesTall = 1 On Error GoTo 0 End With Next End With Sh_Print.PrintOut Copies:=Copies End Sub '*********************************** Sub déleteRow() With F For i = F.[B65000].End(xlUp).Row To 2 Step -1 Application.ScreenUpdating = False If Application.CountA(Range(F.Cells(i, "B"), F.Cells(i, "C"))) = 0 Then F.Rows(i).Delete F.Range("A2:A" & Rows.Count).ClearContents Next i With F.Range("A2:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With End With Application.ScreenUpdating = True End Sub  
نمودج طباعة.xlsm

المرجوا توضيح الطلب الاول او ارفاق عينة للنتائج المتوقعة 
اما بالنسبة للطلب الثاني يمكنك استخدام الكود التالي لجلب اسم الموظف 
Private Sub TextBox1_Change() ' اسماء الموظفين Dim iRow, clé, Myrng, j, r, name$ Set j = Sheets("اسماء الموظفين") Set iRow = j.Range("A2:B" & j.[A65000].End(xlUp).Row) LR = j.Cells(Rows.Count, 1).End(xlUp).Row Myrng = iRow.Value: name = Me.TextBox1.Value Set r = j.Range("A2:A" & LR).Find(name) On Error Resume Next If Not r Is Nothing Then For k = 1 To UBound(Myrng) If Myrng(k, 1) = name Then clé = k Me.réf = clé + iRow.Row - 1: Me.TextBox2 = Myrng(clé, 2) End If Next k Else Me.TextBox2 = Empty End If If Me.TextBox1 = "" Then Me.TextBox2 = "": Me.réf = "" End Sub  
عند كتابة الكود يأتي الاسم.xlsb

Private Sub TextBox7_Change() If IsDate(Me.TextBox7) And IsNumeric(Me.TextBox4) Then Me.TextBox8 = Format(CDate(Me.TextBox7) + CDbl(Me.TextBox4) - 1, "yyyy/mm/dd") Else Me.TextBox8 = "" End If End Sub  
تنسيق التاريخ و اظافة و تعديل.xlsb

تفضل تم تعديل النسخ بداية من الصف 10 اما بخصوص التنسيق في الصورة فوق ليس له اي علاقة بالبيانات الخاصة بك اظافة اخي الفاضل انت تشتغل على يوزرفورم بمعنى التعامل و الترحيل يكون على حسب البيانات الموجودة في الليست بوكس لا اقل ولا اكثر 
ملاحظة تمت اظافة المعادلة المقترحة من طرف الاخ إيهاب عبد الحميد  في اخر مشاركة لك للتجربة 
 
 
مستخلصات الاعمال الجنوبية- V4.xlsm

وعليكم السلام ورحمة الله نعالى وبركاته 
اظن انه يجب عليك اولا تغيير مكان خلية اختيار اسم المادة (N1) خارج نطاق البحث لانه في حالة تم اخفاء عمود مادة الدين مثلا عمود (N) سيتم اخفاء خلية الاختيار  
لنفترض ان الخلية المحددة هي (R1)
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Target.Worksheet.Range("R1")) Is Nothing Then Dim x As Range, rng As Range Set x = Clé([R1], [G7:P7]): Set rng = Columns("E:F") Application.ScreenUpdating = False If x Is Nothing Then MsgBox "مادة" & " " & [R1] & " : " & " غير موجودة ", vbExclamation: Exit Sub Columns("C:P").EntireColumn.Hidden = True x.EntireColumn.Hidden = False: rng.EntireColumn.Hidden = False ActiveWindow.ScrollColumn = 1 End If End Sub Function Clé(a, b As Range) As Range Dim i& On Error Resume Next i = WorksheetFunction.Match(a, b, 0) If i Then Set Clé = b(i) End Function اظهار الاعمدة
Sub Show_all_columns() Sheets("Sheet1").Columns("C:P").EntireColumn.Hidden = False End Sub  
 بطريقة اخرى 
Sub Hide_columns() Dim Clé As Variant, desWS As Worksheet, rng As Range Set desWS = ThisWorkbook.Sheets("Sheet1"): Clé = [R1].Value If Clé > 0 Then With desWS Set rng = .Rows(7).Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Application.ScreenUpdating = False .Columns("C:P").EntireColumn.Hidden = True rng.EntireColumn.Hidden = False .Columns("E:F").EntireColumn.Hidden = False Else MsgBox "مادة" & " " & Clé & " : " & " غير موجودة ", vbExclamation: Exit Sub End If End With End If ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = True End Sub  
صفحة الرصد V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
Private Sub TextBox1_Change() Dim a As Variant, b As Variant, Clé$, Rng As Range, i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("donnes") Dim desWS As Worksheet: Set desWS = Worksheets("search") Clé = "*" & desWS.[B3].Value & "*" Set Rng = desWS.Range("A6:G" & Rows.Count) a = WS.Range("D5", WS.Range("J" & Rows.Count).End(3)).Value If Me.TextBox1 = "" Then Rng.ClearContents Else Application.ScreenUpdating = False With desWS On Error Resume Next .AutoFilterMode = False ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) 'Filter by Uppercase and lowercase letters If LCase(a(i, j)) Like Clé Or UCase(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 Rng.ClearContents: Range("A6").Resize(k, UBound(b, 2)).Value = b Range("d6:d" & Rows.Count).NumberFormat = "dd-mm-yyyy" End With End If Application.ScreenUpdating = True End Sub  
بحث VBA 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

تفضل اليك الحلول التالية
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

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

العيادة.xlsx

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

تفضل اخي قد تم تنفيد المطلوب على الملف المرفق 
بالنسبة لطلب كود انشاء اوراق  عمل باسماء المقاولين ونسخ بياناتهم يمكنك استخدام الكود التالي والدي قد تمت اظافته مسبقا على الملف مع بعض الاكواد  الاظافية ستجدها داخل الملف يمكنك اختيار ما يناسبك 
Sub CreateSheets() Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("الشغل") Dim Col As Range, Sh As Collection, rng As Range, arr As Variant Dim cell As Range, lr As Long, ws As Worksheet Dim Clé As Variant, s As String, SheetName As String Set Col = desWS.Range("C5:C" & desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False Msg = MsgBox(" تحديث العقود " & " " & "؟", vbYesNo, "Admin") If Msg <> vbYes Then Exit Sub desWS.ListObjects(1).ShowAutoFilter = False '*********' قم باظافةاسماء اوراق العمل الغير مرغوب حدفها من المصنف هنا************** SheetName = "الشغل,the report,النسب ,القائمة" '*********************************************************************************** For Each ws In Worksheets If InStr(1, SheetName, ws.Name) = 0 Then F = Application.Match(ws.Name, arr, 0) If IsError(F) Then ws.Delete End If End If Next ws On Error Resume Next For Each cell In Col.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each Clé In Sh s = Clé Sheets.Add(After:=Sheets(Sheets.Count)).Name = Clé ActiveSheet.DisplayRightToLeft = True With desWS.Range("A5:O5") .AutoFilter 3, Clé, xlFilterValues lr = desWS.Columns("C:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = desWS.Range("A4:O" & lr).SpecialCells(xlCellTypeVisible) rng.Copy Sheets(s).Cells(Rows.Count, "A").End(xlUp).Offset(3) .AutoFilter For Each Cpt In Worksheets If InStr(1, SheetName, Cpt.Name) = 0 Then F = Application.Match(Cpt.Name, arr, 0) If IsError(F) Then For i = 1 To 15 Cpt.Columns(i).ColumnWidth = desWS.Columns(i).ColumnWidth Cpt.Rows(i).RowHeight = desWS.Rows(i).RowHeight Next End If End If Next Cpt Sheets(s).Activate Cells.Interior.Color = xlNone With ActiveWindow .SplitColumn = 3: .SplitRow = 0 ActiveWindow.FreezePanes = True End With End With Next Clé desWS.Activate .ScreenUpdating = True .DisplayAlerts = True End With Contractors End Sub بالتوفيق ............
 
الاعمال الجنوبية userform 2.xlsm

جرب هدا الحل بعد اظافة اليوزرفورم  هل يناسبك  
باسوورد 0

الاعمال الجنوبية userform.xlsm

للتوضيح  :  لاسخراج جميع الاوراق في ملف PDF  واحد  يتضمن جميع الطلاب  ربما  يتعين عليك مثلا  نسخ جميع الاوراق المطبوعة  لورقة اخرى  اسفل بعضها البعض  لتتمكن من حفظها بعد دالك .
وهدا يتطلب اظافة ورقة جديدة للمصنف مع انشاء الكود الخاص بدالك . 
اما في حالة الرغبة في حفظها مستقلة اليك الكود التالي سيقوم بحفظ كل ورقة لوحدها في مجلد باسم شهادات الطلاب بعد تسمية كل ملف باسم الطالب الخاص به  
Private Sub CommandButton1_Click() Dim i As Integer, fPath As String, F As String Dim WS As Worksheet: Set WS = Sheet31 'Sheets("Sheet3 (2)") ' اسم ورقة العمل Application.ScreenUpdating = False For i = [AA12] To [AC12] If i <= [AA1] Then [AF2] = 2 * (i - 2) + 3 F = [B8] ' اسم الملف On Error Resume Next With ActiveWorkbook ' قم بتعديل اسم المجلد بما يناسبك fPath = .Path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fPath, vbDirectory)) = 0 Then End If MkDir fPath WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & "\" & F & ".pdf", OpenAfterPublish:=False 'طباعة 'WS.PrintOut End With Next i Application.ScreenUpdating = True End Sub  
 
666 PDF.xlsm

من االافضل دكر ما هي النتيجة المتوقعة من الكود  
جرب ربما هدا ما تقصد 
Sub HideRowsPrint() Dim i As Long, LastRow As Long Application.ScreenUpdating = False StartRow = 9: LastRow = 300 For i = LastRow To StartRow Step -1 If Cells(i, "C") = "" Then Rows(i).Hidden = True Next i Application.ScreenUpdating = True ActiveSheet.PrintPreview ' ActiveSheet.PrintOut Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False End Sub  

Private Sub CommandButton4_Click() Dim WS As Worksheet: Set WS = Sheets("Home") Dim dest As Worksheet: Set dest = Sheets("Daily") Dim search As Range, Rng As Range Set search = WS.[F13]: Set Rng = WS.[F4:F13] If Application.WorksheetFunction.CountA(Rng) = 0 Or search = Empty Then MsgBox "المرجوا إدخال البيانات", vbExclamation, "Admin" Exit Sub Else If Application.WorksheetFunction.CountIf(dest.Range("j:j"), search) > 0 Then MsgBox " تم حفظ هذا اليوم مسبقا" & " " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub a = Array([F4], [F5], [F6], [F7], [F8], [F9], [F10], [F11], [F12], [F13]) dest.[a65000].End(xlUp).Offset(1).Resize(, 10) = a dest.Range("j4:j" & Rows.Count).NumberFormat = "dd/mm/yyyy" Rng.ClearContents MsgBox "تم حفظ البيانات بنجاح" & " " & search & " " & "بنجاح", _ vbInformation, "Done" End If End Sub  
 
تقرير بورتوفيق.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
بعد ادن الاخ @abouelhassan  بما انك ترغب بتنفيد المعادلات على شكل كود اليك حل اخر  رغم انني لا اعلم ما هي الطريقة المطلوبة لتنفيده 
Sub sheets_arrformula() 'Execute On All Worksheets Dim wsName As Worksheet, desWS As Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") For Each wsName In ThisWorkbook.Worksheets If wsName.Name Like "*-JAN" Then 'في حالة اظافة اوراق اخرى للمصنف 'Example February March.......... 1-Feb ,2-Feb.......1-Mar ,2-Mar 'If wsName.Name Like "*-*" Then With Application .ScreenUpdating = False .Calculation = xlManual Set desWS = ThisWorkbook.Sheets(wsName.Name) lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End If Next wsName End Sub ولتنفيد الكود على الورقة النشطة 
Sub Test2() 'Execute On the Active Worksheet Dim lr As Long, lige As Long Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية") Dim desWS As Worksheet: Set desWS = ActiveSheet With Application .ScreenUpdating = False .Calculation = xlManual lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row f = ws.Name Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) If desWS.Name <> f Then lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr) Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr) f = ws.Name lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1 desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")" .Value = .Value End With End With End If .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub  
مصنف v2.xlsm

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 2  قم بتعديل هذا السطر لان البيانات يتم جلبها من ورقة 1 
Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") الى Set WS = Worksheets("Sheet2"): Set desWS = Worksheets("Sheet2")  او تعديله بالكامل بالشكل التالي 
Option Explicit Public Sub TransposeData2() Dim desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = desWS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub  

في حدث Private Sub Worksheet_Activate ضع الكود التالي 
Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub  
السيارات 24.xlsb