VBA to Compile Data from One Sheet to Other Sheets

Dear All,

I hoe you will be doing well.

Please be kind to extend your Benevolence to assist me to achieve the task using excel VBA to sum data base on Product ID and display
output in other sheet of the workbook.


Product ID Product Name Sale Comments Stock Pay
1 GEAR
2 GEAR
3 GEAR
4 GEAR
5 GEAR


I have attached illustration and sample workbook for your kind reference.


Note: Attachment is Neat and Clean, Feel free to open....


Your swift reply would highly be appreciated.

Best Regards,

Formula solution

in "GEAR" C8

Formula:

=SUMIFS(Data!$H:$H,Data!$B:$B,"GEAR",Data!$C:$C,$A8,Data!$A:$A,">=" &GEAR!$B$4,Data!$A:$A,"<=" &EOMONTH(GEAR!$B$4,0))

Column A of "Data" is Date/Time so convert to DATE only

Option Explicit

Sub Compile_Report()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim sh, ocol, dRng(3) As Range
Dim i As Integer, j As Integer, k As Integer, l As Integer, srow As Integer, drow As Integer
Dim sDate As Date

Application.ScreenUpdating = False

Set ws1 = Worksheets("Data")
With ws1  ' Create ranges for data summations
    Set dRng(1) = .Range("H:H")  ' Sale
    Set dRng(2) = .Range("F:F")  ' Stock
    Set dRng(3) = .Range("G:G")  ' Pay
End With

sh = Array("GEAR", "SHANK")      ' Sheet names
ocol = Array(3, 5, 6)            ' Output columns in report sheets

For i = 0 To 1                   ' Loop through output sheets ("GEAR","SHANK")
    Set ws2 = Worksheets(sh(i))
    With ws2
        srow = 8: drow = 4
        sDate = .Cells(drow, "B")  ' January 1st date
        
        For j = 1 To 12            ' Loop through months
            .Cells(drow, "B") = sDate
            
            For k = 1 To 5         ' loop through Products
            
                For l = 1 To 3     ' Loop through Sale, Stock, Pay
                    .Cells(srow + k - 1, ocol(l - 1)) = Application.SumIfs(dRng(l), _
                    ws1.Range("B:B"), sh(i), _
                    ws1.Range("C:C"), .Cells(srow + k - 1, "A"), _
                    ws1.Range("A:A"), ">=" & sDate, _
                    ws1.Range("A:A"), "<=" & WorksheetFunction.EoMonth(sDate, 0))
                Next l
                
            Next k
            
            sDate = Application.EoMonth(sDate, 0) + 1  ' increment date to next month
            drow = drow + 12: srow = srow + 12
            
        Next j
        
    End With
    
Next i

Application.ScreenUpdating = True

End Sub

Dear Bro @JohnTopley,

I am sorry to get back to you again.

Actually, this project need to be run in office 2003. Your solution/Code works fine with Office 2010 and higher.

But it gives error of SUMIFS in office 2003 as shown in the yellow highlighted area in attached screenshot/ code blow in red. coz it is not supported in office 2003

For l = 1 To 3 ' Loop through Sale, Stock, Pay
.Cells(srow + k - 1, ocol(l - 1)) = Application.SumIfs(dRng(l), _
ws1.Range("B:B"), sh(i), _
ws1.Range("C:C"), .Cells(srow + k - 1, "A"), _
ws1.Range("A:A"), ">=" & sDate, _
ws1.Range("A:A"), "<=" & WorksheetFunction.EoMonth(sDate, 0))
Next l

Please be kind to modify SUMIFS and replace it with something else to be worked in older versions using VBA.

Attachment 832945

Thank you!

Thank you @JohnTopley

It perfectly serves for the required purpose and works like a magic...

Thank you so much for your time and prompt support...Big time Appreciated!!!!!

Note that selecting Attachment 832945 results in the following: "Invalid Attachment specified. If you followed a valid link, please notify the administrator".
That said if you want a version 2003 compatible substitute for the SUMIFS formula in post #2, try:

Formula:

=SUMPRODUCT((Data!B$2:B$1481="GEAR")*(Data!C$2:C$1481=A8)*(Data!A$2:A$1481>=B$4)*(Data!A$2:A$1481<=EOMONTH(B$4,0)),Data!H$2:H$1481)

Let us know if you have any questions.

nabsher1,

No need to prepare each Product sheet,
Try the attached.

Sub test()
    Dim a, s, i As Long, ii As Long, col, hd, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("data").[a1].CurrentRegion.Resize(, 9).Value
    col = Array(3, 2, 8, 9, 6, 7)
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 2)) Then Set dic(a(i, 2)) = CreateObject("Scripting.Dictionary")
        s = Format$(a(i, 1), "yyyy mm")
        If Not dic(a(i, 2)).exists(s) Then Set dic(a(i, 2))(s) = CreateObject("Scripting.Dictionary")
        If Not dic(a(i, 2))(s).exists(a(i, 3)) Then
            ReDim w(1 To UBound(col) + 1)
            For ii = 0 To UBound(col)
                w(ii + 1) = a(i, col(ii))
            Next
        Else
            w = dic(a(i, 2))(s)(a(i, 3))
            For ii = 2 To UBound(col)
                w(ii + 1) = w(ii + 1) + a(i, col(ii))
            Next
        End If
        dic(a(i, 2))(s)(a(i, 3)) = w
    Next
    hd = Array("Product ID", "Product Name", "Sale", "Comments", "Stock", "Pay")
    OutPut dic, col, hd
End Sub

Sub OutPut(dic As Object, col, hd)
    Dim e, s, n As Long
    Application.ScreenUpdating = False
    For Each e In dic
        If Not Evaluate("isref('" & e & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = e
        With Sheets(e)
            .Cells.Clear: .Cells.HorizontalAlignment = xlCenter
            .Cells.Font.Name = "Verdana": .Cells.Font.Size = 11
            With .[a1:f1]
                .Merge: .Font.Bold = True: n = 3
                .Cells(1) = "Monthly Wise Report: " & e & " (All Types)"
                .BorderAround Weight:=2
            End With
            For Each s In dic(e)
                With .Cells(n, "b").Resize(2, 5)
                    .Font.Bold = True: .Borders.Weight = 2: n = n + 3
                    .Rows(1) = Array("Month", "Manager", "", "Admin", "Accounts")
                    With .Cells(1, 2).Resize(2, 2)
                        .HorizontalAlignment = 7
                        .Range("a1:a2").Borders(10).LineStyle = xlNone
                    End With
                    .Cells(2, 1) = "'" & Format$(DateSerial(Split(s)(0), Split(s)(1), 1), "mmm-yyyy")
                End With
                With .Cells(n, "b").Resize(, 5)
                    .Merge: .Font.Bold = True: n = n + 1
                    .Cells(1) = ":::Monthly Detail:::"
                End With
                With .Cells(n, "a").Resize(dic(e)(s).Count + 1, 6)
                    .Rows(1) = hd: .Rows(1).Font.Bold = True
                    With .Rows(2).Resize(dic(e)(s).Count)
                        .Value = Application.Index(dic(e)(s).items, 0, 0)
                        .Sort .Cells(1)
                    End With
                    .Borders.Weight = 2
                    With .Cells(.Rows.Count + 1, 6)
                        .Font.Bold = True
                        .FormulaR1C1 = "=sum(r" & n + 1 & "c:r[-1]c)"
                        .Borders.Weight = 2
                    End With
                    n = n + .Rows.Count + 2
                End With
            Next
            .Columns("d").Replace 0, "", 1
            .Columns("a:f").ColumnWidth = 17.89
            .Rows.RowHeight = 18
        End With
    Next
    Application.ScreenUpdating = True
End Sub

Option Explicit

Sub Compile_Report()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim sh, ocol, a, b
Dim i As Integer, j As Integer, k As Integer, l As Integer, srow As Integer, drow As Integer, r As Long, lr As Long
Dim sDate As Date, eDate As Date

Application.ScreenUpdating = False

Set ws1 = Worksheets("Data")
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
a = ws1.[a1].CurrentRegion

sh = Array("GEAR", "SHANK")      ' Sheet names

For i = 0 To 1                   ' Loop through output sheets ("GEAR","SHANK")

    Set ws2 = Worksheets(sh(i))
   
        srow = 8: drow = 4
        sDate = ws2.Cells(drow, "B")  ' January 1st date
        
            For j = 1 To 12            ' Loop through months
        
                ws2.Cells(drow, "B") = sDate
                'ws2.Range("C" & srow & ":F" & srow + 4).Clear
                eDate = WorksheetFunction.EoMonth(sDate, 0)
                
                ReDim b(1 To 5, 1 To 6)  ' dimension temporay working array
                
                For k = 1 To 5    ' Assign "Product ID" and "Product Name"
                 b(k, 1) = k: b(k, 2) = sh(i)
                Next k
                
                For r = 2 To lr   ' Loopthrogh input
                    ' Check if "this" month and this "Product Name"
                    If a(r, 1) >= sDate And a(r, 1) <= eDate And a(r, 2) = sh(i) Then
                        k = a(r, 3)   ' "Product ID" ( 1 to 5)
                        ' Sum values of Sales, Stock and Pay
                        b(k, 3) = b(k, 3) + a(r, 8): b(k, 5) = b(k, 5) + a(r, 6): b(k, 6) = b(k, 6) + a(r, 7)
                    End If
                
               Next r
               
                With ws2   'Output results
                    .Range("A" & srow).Resize(5, 6) = b
                    .Range("C" & srow & ":F" & srow + 4).Borders.Weight = 2
                    .Range("C" & srow & ":F" & srow + 4).HorizontalAlignment = xlCenter
                    .Range("C" & srow & ":C" & srow + 4).NumberFormat = "#0.00"
                    .Range("E" & srow & ":F" & srow + 4).NumberFormat = "#0.00"
                    
                End With
                
                sDate = Application.EoMonth(sDate, 0) + 1  ' increment date to next month
                drow = drow + 12: srow = srow + 12         ' Pointers to output rows
            
            Next j
    
Next i

Application.ScreenUpdating = True

End Sub

A work-around BUT you really must upgrade Excel and get rid of 2003

Option Explicit

Sub Compile_Report()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim sh, a, b, dm As Variant
Dim i As Integer, j As Integer, k As Integer, l As Integer, srow As Integer, drow As Integer, r As Long, lr As Long
Dim sDate As Date, eDate As Date

Application.ScreenUpdating = False

dm = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

Set ws1 = Worksheets("Data")

a = ws1.[a1].CurrentRegion       ' Input data into array

sh = Array("GEAR", "SHANK")      ' Sheet names

For i = 0 To 1                   ' Loop through output sheets ("GEAR","SHANK")

    Set ws2 = Worksheets(sh(i))  ' Set worksheet name
   
        srow = 8: drow = 4
        sDate = ws2.Cells(drow, "B")  ' January 1st date
        
            For j = 1 To 12            ' Loop through months
        
                ws2.Cells(drow, "B") = sDate
                'eDate = WorksheetFunction.EoMonth(sDate, 0)
                eDate = sDate + dm(j) - 1
                If Year(sDate) Mod 4 = 0 And j = 2 Then eDate = eDate + 1  ' Test for leap year and February so add 1 day
                
                
                ReDim b(1 To 5, 1 To 6)  ' dimension/clear  temporary working array
                
                For k = 1 To 5    ' Assign "Product ID" and "Product Name"
                 b(k, 1) = k: b(k, 2) = sh(i)
                Next k
                
                For r = 2 To UBound(a, 1)  ' Loop through input
                    ' Check if "this" month and this "Product Name"
                    If a(r, 1) >= sDate And a(r, 1) <= eDate And a(r, 2) = sh(i) Then
                        k = a(r, 3)   ' "Product ID" ( 1 to 5)
                        ' Sum values of Sales, Stock and Pay
                        b(k, 3) = b(k, 3) + a(r, 8): b(k, 5) = b(k, 5) + a(r, 6): b(k, 6) = b(k, 6) + a(r, 7)
                    End If
                
               Next r
               
                With ws2   'Output results
                
                    .Range("A" & srow).Resize(5, 6) = b
                    .Range("C" & srow & ":F" & srow + 4).Borders.Weight = 2
                    .Range("C" & srow & ":F" & srow + 4).HorizontalAlignment = xlCenter
                    
                    .Range("C" & srow & ":C" & srow + 4).NumberFormat = "#0.00"
                    .Range("E" & srow & ":F" & srow + 4).NumberFormat = "#0.00"
                    
                End With
                
             '   sDate = Application.EoMonth(sDate, 0) + 1  ' increment date to next month
               sDate=eDate+1
                
                drow = drow + 12: srow = srow + 12         ' Pointers to output rows
            
            Next j
    
Next i

Application.ScreenUpdating = True

End Sub