تجميع البيانات اسبوعيا

[محمد ايمن]

الأصدقاء الاكارم السلام عليكم و رحمة الله و بركاته

لدي صفحة تحتوي علي بيانات المبيعات حسب التاريخ

اريد تجميع البيانات أسبوعيا

أي انني اريد مجموع كل أسبوع على حدة

ملاحظة : لا تهمني طريقة التجميع سواء باستخدام كود او معادلات او استعلامات او جدول محوري

 

المصنف1.xlsx

[abouelhassan]

لتجميع البيانات أسبوعياً، يمكنك استخدام الصيغ الشيتية في Excel للتجميع. يمكنك اتباع الخطوات التالية:

 

1. إضافة عمود جديد لتحديد الأسبوع.

2. في الخلية A2، اكتب الصيغة التالية لاستخراج تاريخ الأسبوع:

   ```

   =TEXT(A2, "ww")

   ```

   حيث A2 هو الخلية التي تحتوي على التاريخ.

3. في الخلية C2، اكتب الصيغة التالية لجمع البيانات الأسبوعية:

   ```

   =SUMIF($A$2:$A$35, "="&A2, $B$2:$B$35)

   ```

   حيث A2:A35 تحتوي على تواريخ الأسابيع، وB2:B35 تحتوي على القيم المرتبطة.

4. اسحب الصيغتين لأسفل لتطبيقهما على بقية الصفوف.

 

هذا سيقوم بتجميع القيم الأسبوعية في العمود C حسب الأسبوع المحدد.

 

جرب إذا كنت ترغب في استخدام VBA لتجميع البيانات أسبوعيًا، يمكنك استخدام الكود التالي. يفترض أن لديك بيانات في الأعمدة A و B، وترغب في تجميعها أسبوعيًا في أعمدة C وD

Sub AggregateWeekly()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim weekStartDate As Date
    Dim totalSales As Double
    Dim targetRow As Long

    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' Find the last row with data
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Initialize variables
    totalSales = 0
    targetRow = 2 ' Start from row 2 (assuming row 1 is headers)

    ' Loop through the rows
    For i = 2 To lastRow
        ' Check if the current date is in the same week as the start date
        If Weekday(ws.Cells(i, 1).Value, vbMonday) = 2 Then
            ' Add the sales to the total
            totalSales = totalSales + ws.Cells(i, 2).Value
        End If
        
        ' If the current date is the last day of the week or the last row, write the total sales for the week
        If Weekday(ws.Cells(i, 1).Value, vbMonday) = 1 Or i = lastRow Then
            ' Write the week start date
            ws.Cells(targetRow, 3).Value = ws.Cells(i, 1).Value - Weekday(ws.Cells(i, 1).Value, vbMonday) + 1
            ' Write the total sales for the week
            ws.Cells(targetRow, 4).Value = totalSales
            ' Move to the next row
            targetRow = targetRow + 1
            ' Reset the total sales for the next week
            totalSales = 0
        End If
    Next i
End Sub

هذا الكود يقوم بتجميع البيانات الأسبوعية ووضعها في أعمدة جديدة. يمكنك تعديل اسماء الاعمدة والورقة حسب احتياجك.

تم تعديل فبراير 28 بواسطه abouelhassan

[محمد هشام.]

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

مجرد فكرة ربما تناسبك 

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 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

تم تعديل فبراير 29 بواسطه محمد هشام.

[محمد ايمن]

جزيل الشكر لكم اخوتي

حل آخر باستخدام بور كويري

 

المصنف1.xlsx