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

[ابو نبأ]

السلام عليكم 

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

مع لطفا

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

فرز بيانات.xlsm

[محمد هشام.]

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

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

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

[ابو نبأ]

السلام عليكم

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

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

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

[محمد هشام.]

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

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

[ابو نبأ]

السلام عليكم

جزاك الله خير

والله كود جميل

ولكن عندي بعض الملاحظات

وضحته في شيت نموذج

 

فرز - نموذح.xlsm

[محمد هشام.]

 

أخي هذه إظافات ليس بملاحظات من الأفضل دائماً توضيح المطلوب دفعة واحدة. تفاديا الاشتغال على الملف أكثر من مرة. 

لقد تم التركيز على الفرز وحفظ الملفات كما جاء في طلبك اول مرة. رغم ان ملفك المرفق لا يقوم بشرح المطلوب جيدا. ... 

 

 

 

قل لنا ماتم انجازه وما تبقى

[محمد هشام.]

تفضل اخي هدا حل اخر على حسب ما فهمت من اخر ملف قمت برفعه 

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

شيت النتائج

مع استخراج بيانات كل اسبوع في شيت مستقل بدون تكرار للتواريخ . وحفظ الكل في مجلد في بارتشن (E)

 

 

 

 

فرز بيانات V2.rar