وعليكم السلام ورحمة الله تعالى وبركاته
تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF)
مع تنسيق الجداول بنفس التنسيق المرفق في طلبك .
Public Sub Split_Sheet_condition_of_the_week()
Dim dataSheet As Worksheet, weekSheet As Worksheet
Dim minDate As Date, maxDate, weekStartDate As Date
Dim lr As Long, c As Long, LastRow As Long, MH As Variant
Dim weekSheetName As String, WS_Address As String
Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String
Dim WS_Data As Range, Total_Rng As Range
Dim wsData As Worksheet: Set wsData = Worksheets("تجميع")
'حدف جميع اوراق العمل باستثناء ورقة التجميع
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> "تجميع" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
Set dataSheet = wsData
With dataSheet
lr = .Cells(.Rows.Count, "F").End(xlUp).Row
'اصغر تاريخ
minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr))
' اكبر تاريخ
maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr))
End With
weekStartDate = Date_Prev_Saturday(minDate)
While weekStartDate <= maxDate
'تسمية الشيتات
weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d")
With ActiveWorkbook
Set weekSheet = Nothing
On Error Resume Next
Set weekSheet = .Worksheets(weekSheetName)
On Error GoTo 0
If weekSheet Is Nothing Then
'اظافة وتسمية اوراق العمل
Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
weekSheet.Name = weekSheetName
weekSheet.DisplayRightToLeft = True
Else
weekSheet.Cells.Clear
End If
End With
'فلترة البيانات
weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value)
weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6)
dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False
weekSheet.Range("l1:m2").Clear
weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16
LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F"))
MH = (RGB(153, 153, 255))
' اظافة المعادلات
weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)"
weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow)
weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)"
Cells(LastRow + 1, 1).Value = "المجموع"
For c = 2 To 6
Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c)))
Next c
'تنسيق الجدول
Total_Rng.Interior.Color = MH
Total_Rng.Font.Bold = True
Total_Rng.Font.Size = 13
With Range("A5:F" & LastRow + 1)
.HorizontalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 16
.Value = .Value
End With
'تسطير الجدول
DL = weekSheet.Range("A65500").End(xlUp).Row
DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column
Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin
'فواصل الصفحات
With weekSheet.Range("A5:A" & _
weekSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not WS_Data Is Nothing Then
WS_Address = WS_Data.Address
Do
If Not WS_Data Is Nothing Then
WS_Data.Offset(1).PageBreak = xlPageBreakManual
End If
Set WS_Data = .FindNext(WS_Data)
If WS_Data Is Nothing Then
Exit Do
End If
If WS_Data.Address = WS_Address Then
Exit Do
End If
Loop
End If
End With
On Error Resume Next
ActiveWindow.View = xlPageBreakPreview
weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
ActiveWindow.View = xlNormalView
' إنشاء مجلد الحفظ
ST_Name = "فرز البيانات الأسبوعية"
ST_DATA = ""
ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك
'ST_WS_Data = "D:\"
If IsEmpty(ST_Name) Then Exit Sub
If IsEmpty(ST_DATA) Then Exit Sub
MkDir ST_WS_Data & "\" & ST_Name
ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA
' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ
weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False
weekStartDate = weekStartDate + 7
Wend
dataSheet.Select
MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _
FolderName, _
vbInformation, " : تم حفظ الملفات بنجاح في "
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Private Function Date_Prev_Saturday(fromDate As Date) As Date
Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate))
End Function
بالتوفيق..........
تجميع V1.xlsm