Script for reporting

Ganastia

New Member
Joined
Nov 7, 2023
Messages
3
Office Version
  1. 365
Platform
  1. Windows
I have been placed in charge of reporting in my small company and my excel experience is semi-limited and would love is someone can assist me with this issue. We have Daily/Weekly reports that when it has been turned over seem very inefficient and I'm trying to streamline it.

Our reports are pulled from our system below and we manually sort the whole sheet using the information in column A. We then add 2 rows underneath each unique value based on Column A, we then add a COUNTA function to count how many times that unique value was used in bold under Column C and a SUM under Column K. There is also a final total based on those COUNTA and SUM Formulas on the very bottom. I'll include 2 mini sheets, the first with an example of how data is pulled vs how the final table looks. I have attempted to use AI to write this for me but it can't get the script right so I figured I'd come to the experts if you would be so kind as to assist with this.

Initial Pull
Example v2.xlsx
ABCDEFGHIJK
1NameNumberInfoData2Data3Data4Data5Data6Data7Data8Amount
2Dan1aaaaaaaa123456
3Bob10bbbbbbbb234567
4Sally9cccccccc345678
5Sue8bbbbbbbb456789
6Dan5aaaaaaaa134679
7Bob3dddddddd258258
8Sally6eeeeeeee978542
9Sue2aaaaaaaa654321
10Dan4cccccccc623875
11Bob7gggggggg123669
Sheet1


Final Product
Example v2.xlsx
ABCDEFGHIJK
1NameNumberInfoData2Data3Data4Data5Data6Data7Data8Amount
2Bob10bbbbbbbb$234,567.00
3Bob3dddddddd$258,258.00
4Bob7gggggggg$123,669.00
53$616,494.00
6
7Dan1aaaaaaaa$123,456.00
8Dan5aaaaaaaa$134,679.00
9Dan4cccccccc$623,875.00
103$882,010.00
11
12Sally9cccccccc$345,678.00
13Sally6eeeeeeee$978,542.00
142$1,324,220.00
15
16Sue8bbbbbbbb$456,789.00
17Sue2aaaaaaaa$654,321.00
182$1,111,110.00
19
2010$3,933,834.00
Sheet1
Cell Formulas
RangeFormula
C5,C10C5=COUNTA(C2:C4)
K5,K10K5=SUM(K2:K4)
C14,C18C14=COUNTA(C12:C13)
K14,K18K14=SUM(K12:K13)
C20,K20C20=SUM(C18,C14,C10,C5)
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
I have been placed in charge of reporting in my small company and my excel experience is semi-limited and would love is someone can assist me with this issue. We have Daily/Weekly reports that when it has been turned over seem very inefficient and I'm trying to streamline it.

Our reports are pulled from our system below and we manually sort the whole sheet using the information in column A. We then add 2 rows underneath each unique value based on Column A, we then add a COUNTA function to count how many times that unique value was used in bold under Column C and a SUM under Column K. There is also a final total based on those COUNTA and SUM Formulas on the very bottom. I'll include 2 mini sheets, the first with an example of how data is pulled vs how the final table looks. I have attempted to use AI to write this for me but it can't get the script right so I figured I'd come to the experts if you would be so kind as to assist with this.

Initial Pull
Example v2.xlsx
ABCDEFGHIJK
1NameNumberInfoData2Data3Data4Data5Data6Data7Data8Amount
2Dan1aaaaaaaa123456
3Bob10bbbbbbbb234567
4Sally9cccccccc345678
5Sue8bbbbbbbb456789
6Dan5aaaaaaaa134679
7Bob3dddddddd258258
8Sally6eeeeeeee978542
9Sue2aaaaaaaa654321
10Dan4cccccccc623875
11Bob7gggggggg123669
Sheet1


Final Product
Example v2.xlsx
ABCDEFGHIJK
1NameNumberInfoData2Data3Data4Data5Data6Data7Data8Amount
2Bob10bbbbbbbb$234,567.00
3Bob3dddddddd$258,258.00
4Bob7gggggggg$123,669.00
53$616,494.00
6
7Dan1aaaaaaaa$123,456.00
8Dan5aaaaaaaa$134,679.00
9Dan4cccccccc$623,875.00
103$882,010.00
11
12Sally9cccccccc$345,678.00
13Sally6eeeeeeee$978,542.00
142$1,324,220.00
15
16Sue8bbbbbbbb$456,789.00
17Sue2aaaaaaaa$654,321.00
182$1,111,110.00
19
2010$3,933,834.00
Sheet1
Cell Formulas
RangeFormula
C5,C10C5=COUNTA(C2:C4)
K5,K10K5=SUM(K2:K4)
C14,C18C14=COUNTA(C12:C13)
K14,K18K14=SUM(K12:K13)
C20,K20C20=SUM(C18,C14,C10,C5)
I just realized I didn't include that the sheet on each pull is named "Data"
 
Upvote 0
Welcome to MrExcel

I couldn't sleep so I put this together for you.

It contains some generic code so if you have other similar reports that need creating just let me know and it can be adapted for those.

It assumes that the sheet that contains your data is named 'Data'.
If this is different then change this line of code.
strOriginalDataSheet = "Data"

It also puts the report into a sheet named 'Report'
If this is to be different then change this line of code.
strReportSheet = "Report"

It creates a temporary sheet to avoid changing the source data sheet.
This temporary worksheet is named 'Temp'
If you have another sheet with the same name then change this line of code.
strTempSheet = "Temp"
It deletes this sheet after the report has been created.

Test this in a workbook that just contains your source data worksheet.

The procedure 'subReporting' is the one that you run.

There is no need to sort the data first as the code does it for you.

VBA Code:
Public Sub subReporting()
Dim WsTemp As Worksheet
Dim WsReport As Worksheet
Dim rngData As Range
Dim arrUnique() As Variant
Dim i As Integer
Dim intRow As Integer
Dim intRows As Integer
Dim strOriginalDataSheet As String
Dim strTempSheet As String
Dim strReportSheet As String

  ActiveWorkbook.Save
  
  strOriginalDataSheet = "Data"
  
  strTempSheet = "Temp"
  
  strReportSheet = "Report"
  
  ' Copy original data to temporary worksheet for subtotals.
  ' The original data worksheet is not altered.
  Call subCopySourceData(strOriginalDataSheet, strTempSheet)

  ' Set source data worksheet object
  Set WsTemp = Worksheets(strTempSheet)
  
  Set rngData = WsTemp.Range("A1").CurrentRegion
  
  ' Get the number of rows of data.
  intRows = rngData.Rows.Count - 1
  
  ' Get unique list of values to group on.
  arrUnique = Evaluate("SORT(UNIQUE(" & rngData.Range("A1").Resize(intRows, 1).Offset(1, 0).Address & ",FALSE,FALSE))")
  
  ' Sort the data by column one.
  With WsTemp
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:=rngData.Columns("A").Resize(rngData.Columns("A").Rows.Count - 1, 1), _
      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rngData
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  End With
  
  ' Group and create sub totals.
  rngData.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(11), _
      Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    
  Set WsReport = fncCreateWorksheet(strReportSheet)
    
  ' Copy the data from the subtotals sheet.
  WsTemp.Range("A1").CurrentRegion.Copy WsReport.Range("A1")
  
  Call subDeleteWorksheet(WsTemp)
  
  ' Format the report worksheet.
  Call subFormatReport(WsReport)
    
  With WsReport.Range("A1").CurrentRegion
  
    ' Insert row count per group.
    For i = LBound(arrUnique) To UBound(arrUnique)
      intRow = WorksheetFunction.Match(arrUnique(i, 1) & " Total", .Columns(1), 0)
      .Cells(intRow, "A").Value = ""
      .Rows(intRow + 1).EntireRow.Insert
      .Rows(intRow).Font.Bold = True
      .Cells(intRow, 3).Value = WorksheetFunction.CountIf(.Columns(1), arrUnique(i, 1))
    Next i
    
    ' Remove 'Grand Total'
    .Cells(.Rows.Count, 1).Value = ""
    
    ' Insert total number of rows of data and bold last row.
    With .Rows(.Rows.Count)
      .Cells(3) = intRows
      .Font.Bold = True
    End With
    
    ' Set last column to currency.
    .Columns(.Columns.Count).NumberFormat = "£#,##0.00"
  
  End With
    
  ActiveWorkbook.Save
  
End Sub

Private Sub subFormatReport(WsReport As Worksheet)

  With WsReport.UsedRange
    .Font.Name = "Arial"
    .Font.Size = 14
    .Cells.EntireColumn.AutoFit
    .Cells.RowHeight = 25
  End With

End Sub

Private Sub subCopySourceData(strSourceWorksheet, strDestinationWorksheet)

  Application.DisplayAlerts = False
  On Error Resume Next
  Worksheets(strDestinationWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
  Worksheets(strSourceWorksheet).Copy after:=Sheets(Sheets.Count)
  
  ActiveSheet.Name = strDestinationWorksheet
  
End Sub

Public Sub subDeleteWorksheet(Ws As Worksheet)

  Application.DisplayAlerts = False
  On Error Resume Next
  Ws.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
End Sub

Public Function fncCreateWorksheet(strWorksheet As String) As Worksheet
Dim strActive As String

  strActive = ActiveSheet.Name
  
  Application.DisplayAlerts = False
  On Error Resume Next
  Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
  Worksheets.Add after:=Sheets(Sheets.Count)

  ActiveSheet.Name = strWorksheet
  
  Set fncCreateWorksheet = ActiveSheet

  Worksheets(strActive).Activate
  
End Function
 
Upvote 0
Solution
Welcome to MrExcel

I couldn't sleep so I put this together for you.

It contains some generic code so if you have other similar reports that need creating just let me know and it can be adapted for those.

It assumes that the sheet that contains your data is named 'Data'.
If this is different then change this line of code.
strOriginalDataSheet = "Data"

It also puts the report into a sheet named 'Report'
If this is to be different then change this line of code.
strReportSheet = "Report"

It creates a temporary sheet to avoid changing the source data sheet.
This temporary worksheet is named 'Temp'
If you have another sheet with the same name then change this line of code.
strTempSheet = "Temp"
It deletes this sheet after the report has been created.

Test this in a workbook that just contains your source data worksheet.

The procedure 'subReporting' is the one that you run.

There is no need to sort the data first as the code does it for you.

VBA Code:
Public Sub subReporting()
Dim WsTemp As Worksheet
Dim WsReport As Worksheet
Dim rngData As Range
Dim arrUnique() As Variant
Dim i As Integer
Dim intRow As Integer
Dim intRows As Integer
Dim strOriginalDataSheet As String
Dim strTempSheet As String
Dim strReportSheet As String

  ActiveWorkbook.Save
 
  strOriginalDataSheet = "Data"
 
  strTempSheet = "Temp"
 
  strReportSheet = "Report"
 
  ' Copy original data to temporary worksheet for subtotals.
  ' The original data worksheet is not altered.
  Call subCopySourceData(strOriginalDataSheet, strTempSheet)

  ' Set source data worksheet object
  Set WsTemp = Worksheets(strTempSheet)
 
  Set rngData = WsTemp.Range("A1").CurrentRegion
 
  ' Get the number of rows of data.
  intRows = rngData.Rows.Count - 1
 
  ' Get unique list of values to group on.
  arrUnique = Evaluate("SORT(UNIQUE(" & rngData.Range("A1").Resize(intRows, 1).Offset(1, 0).Address & ",FALSE,FALSE))")
 
  ' Sort the data by column one.
  With WsTemp
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:=rngData.Columns("A").Resize(rngData.Columns("A").Rows.Count - 1, 1), _
      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rngData
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  End With
 
  ' Group and create sub totals.
  rngData.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(11), _
      Replace:=True, PageBreaks:=False, SummaryBelowData:=True
   
  Set WsReport = fncCreateWorksheet(strReportSheet)
   
  ' Copy the data from the subtotals sheet.
  WsTemp.Range("A1").CurrentRegion.Copy WsReport.Range("A1")
 
  Call subDeleteWorksheet(WsTemp)
 
  ' Format the report worksheet.
  Call subFormatReport(WsReport)
   
  With WsReport.Range("A1").CurrentRegion
 
    ' Insert row count per group.
    For i = LBound(arrUnique) To UBound(arrUnique)
      intRow = WorksheetFunction.Match(arrUnique(i, 1) & " Total", .Columns(1), 0)
      .Cells(intRow, "A").Value = ""
      .Rows(intRow + 1).EntireRow.Insert
      .Rows(intRow).Font.Bold = True
      .Cells(intRow, 3).Value = WorksheetFunction.CountIf(.Columns(1), arrUnique(i, 1))
    Next i
   
    ' Remove 'Grand Total'
    .Cells(.Rows.Count, 1).Value = ""
   
    ' Insert total number of rows of data and bold last row.
    With .Rows(.Rows.Count)
      .Cells(3) = intRows
      .Font.Bold = True
    End With
   
    ' Set last column to currency.
    .Columns(.Columns.Count).NumberFormat = "£#,##0.00"
 
  End With
   
  ActiveWorkbook.Save
 
End Sub

Private Sub subFormatReport(WsReport As Worksheet)

  With WsReport.UsedRange
    .Font.Name = "Arial"
    .Font.Size = 14
    .Cells.EntireColumn.AutoFit
    .Cells.RowHeight = 25
  End With

End Sub

Private Sub subCopySourceData(strSourceWorksheet, strDestinationWorksheet)

  Application.DisplayAlerts = False
  On Error Resume Next
  Worksheets(strDestinationWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
 
  Worksheets(strSourceWorksheet).Copy after:=Sheets(Sheets.Count)
 
  ActiveSheet.Name = strDestinationWorksheet
 
End Sub

Public Sub subDeleteWorksheet(Ws As Worksheet)

  Application.DisplayAlerts = False
  On Error Resume Next
  Ws.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
 
End Sub

Public Function fncCreateWorksheet(strWorksheet As String) As Worksheet
Dim strActive As String

  strActive = ActiveSheet.Name
 
  Application.DisplayAlerts = False
  On Error Resume Next
  Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
 
  Worksheets.Add after:=Sheets(Sheets.Count)

  ActiveSheet.Name = strWorksheet
 
  Set fncCreateWorksheet = ActiveSheet

  Worksheets(strActive).Activate
 
End Function
You are a lifesaver!!!

The good news is I have convinced the upper management to standardize all daily/weekly reporting to appear in the same format so this should work for all!

I did have to alter the code a bit as the source data actually goes until column Y but I made the mini-sheet example so small as those are the only columns that have an item placed underneath them. I altered the code to no longer change the last column to currency which was an easy fix (Thank you for describing every function - that was very helpful). I also removed the lines that formatted the new sheet as I am trying to keep the source formatting as it allows all columns to be on one legal sheet of paper and not require a magnifying glass.

I cannot say enough thank you's for your help on this you just saved me hours of adding lines to reports every day! I definitely owe you a beer!
 
Upvote 0
You are a lifesaver!!!

The good news is I have convinced the upper management to standardize all daily/weekly reporting to appear in the same format so this should work for all!

I did have to alter the code a bit as the source data actually goes until column Y but I made the mini-sheet example so small as those are the only columns that have an item placed underneath them. I altered the code to no longer change the last column to currency which was an easy fix (Thank you for describing every function - that was very helpful). I also removed the lines that formatted the new sheet as I am trying to keep the source formatting as it allows all columns to be on one legal sheet of paper and not require a magnifying glass.

I cannot say enough thank you's for your help on this you just saved me hours of adding lines to reports every day! I definitely owe you a beer!
I'm glad that it helped.

All reports need to be standardized in terms of look and automated as far as possible. BUT along with this goes a standard
way of coding, well documented code and workbook and worksheet naming conventions.

If you need any help in automating other reports then just submit another post and message me with the link.

I don't drink beer but I do eat lots of cake. 🍰🍰🍰
 
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,286
Members
452,631
Latest member
a_potato

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top