فرز بيانات كل مدة معينة ووضعها في شيت

ابو نبأ · مايو 2, 2023

السلام عليكم

ممكن فرز البيانات الموجودة في شيت تجميع كل سبعة ايام في شيت

مع لطفا

حفظ كل شيت المفروز بصيغة بي دي اف في فورلدر موجود في (E) باسم (فرز البيانات الاسبوعية)

فرز بيانات.xlsm

**محمد هشام.** · مايو 14, 2023

وعليكم السلام ورحمة الله وبركاته

أخي المرجوا توضيح عدد الأعمدة المراد نسخها عند فلترة التواريخ أو تحديد النطاق المطلوب!!!

تم تعديل مايو 14, 2023 بواسطه Mohamed Hicham

ابو نبأ · مايو 15, 2023

السلام عليكم

اني موضح المطلوب من خلال شيتات الموجودة بالملف - وعامل مثال موضح به

الله يرضى - واشكرك على الاهتمام

فرز بيانات (2).xlsm

**محمد هشام.** · مايو 16, 2023

وعليكم السلام ورحمة الله تعالى وبركاته

تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (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

تم تعديل مايو 16, 2023 بواسطه Mohamed Hicham