اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

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

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

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

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

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

 

المصنف1.xlsx

قام بنشر (معدل)

لتجميع البيانات أسبوعياً، يمكنك استخدام الصيغ الشيتية في 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

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

تم تعديل بواسطه abouelhassan
  • Like 2
قام بنشر

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

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

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

  • Like 1
  • أفضل إجابة
قام بنشر (معدل)

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

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

تم تعديل بواسطه محمد هشام.
  • Like 2

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information