Optimizing large Excel report

Question

I have a problem with generation of my report. Data is read from other sheet in report. Most time is wasted on execution of LineColor() and LineGroup(). Those operations are based on hierarchy, which is copied and pasted into cells parallel to every row.

CoreElementCode CategoryCode SubcategoryCode BMCCode ProductId
1 30 167 1307 1000152
1 30 167 1307 1000152
1 30 167 1307 1307
1 30 167 1307 1307
1 30 167 167 167
1 30 167 167 167
1 30 30 30 30
1 30 30 30 30
1 10 101 1014 1000112
1 10 101 1014 1000112
1 10 101 1014 1014
1 10 101 1014 1014
1 10 101 1013 1000142
1 10 101 1013 1000142
1 10 101 1013 1013
1 10 101 1013 1013
1 10 101 1008 1000122
1 10 101 1008 1000122
1 10 101 1008 1008
1 10 101 1008 1008
1 10 101 101 101
1 10 101 101 101
1 10 100 1306 1000132
1 10 100 1306 1000132

I'am looking for advice on how to make this code faster. Current generation (with 22 thousands rows in Data_Load spreadsheet) takes 2 hours.

Option Explicit
Public ReportWeek As String
Sub CreateReport()
Load_Data
ReportWeek = Sheets("Headers").Cells(24, 1).Value
Sheets("Category_Sales").Activate
Application.DisplayAlerts = False
ActiveSheet.PivotTables("SalesCategory").PivotCache.Refresh
Cells(12, 2).Value = "1"
Cells(12, 3).Value = "2"
Cells(12, 4).Value = "3"
Cells(12, 5).Value = "4"
Cells(12, 6).Value = "5"
Cells(12, 18).Value = "1"
Cells(12, 19).Value = "2"
Cells(12, 20).Value = "3"
Cells(12, 21).Value = "4"
Cells(12, 22).Value = "5"
Cells(12, 2).Value = Sheets("Headers").Cells(2, 1).Value
Cells(12, 3).Value = Sheets("Headers").Cells(3, 1).Value
Cells(12, 4).Value = Sheets("Headers").Cells(4, 1).Value
Cells(12, 5).Value = Sheets("Headers").Cells(5, 1).Value
Cells(12, 6).Value = Sheets("Headers").Cells(6, 1).Value
Cells(12, 18).Value = Sheets("Headers").Cells(2, 1).Value
Cells(12, 19).Value = Sheets("Headers").Cells(3, 1).Value
Cells(12, 20).Value = Sheets("Headers").Cells(4, 1).Value
Cells(12, 21).Value = Sheets("Headers").Cells(5, 1).Value
Cells(12, 22).Value = Sheets("Headers").Cells(6, 1).Value
 With ActiveSheet.PivotTables("SalesCategory").PivotFields("CoreElementCode")
 .Orientation = xlRowField
 .Position = 2
 End With
 With ActiveSheet.PivotTables("SalesCategory").PivotFields("CategoryCode")
 .Orientation = xlRowField
 .Position = 3
 End With
 With ActiveSheet.PivotTables("SalesCategory").PivotFields("SubcategoryCode")
 .Orientation = xlRowField
 .Position = 4
 End With
 With ActiveSheet.PivotTables("SalesCategory").PivotFields("BMCCode")
 .Orientation = xlRowField
 .Position = 5
 End With
 With ActiveSheet.PivotTables("SalesCategory").PivotFields("ProductID")
 .Orientation = xlRowField
 .Position = 6
 End With
Dim rng As Range
Dim MaxLineNumber As Integer
'Column with LineOrder
'Set rng = Worksheets("Data").Range("O1:O25000")
'Find max LineOrder(line number)
Dim nonEmptyRowsNumber As Long
Dim WorkRange As Range
nonEmptyRowsNumber = Worksheets("Data_Load").UsedRange.Columns("O").Rows.Count
Set WorkRange = Worksheets("Data_Load").Range("O2:O" & nonEmptyRowsNumber)
MaxLineNumber = Application.Max(WorkRange)
Range("B13:F" & MaxLineNumber + 1).Select 'wyzej wstawione GMH, pole po polu
Selection.Copy
Range("BL13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
ActiveSheet.PivotTables("SalesCategory").PivotFields("CoreElementCode"). _
Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("CategoryCode"). _
Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("SubcategoryCode"). _
Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("BMCCode"). _
Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("ProductID"). _
Orientation = xlHidden
LineColor (MaxLineNumber)
LineGroup (MaxLineNumber)
Columns("BL:BP").Select 'kasowanie pól z GMH
Selection.Delete
Sheets("Category_Sales").PivotTables("SalesCategory").ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:="E:\Reports\Main\[MPF_Sales.xlsb]Data_Load!C1:C19", Version:=xlPivotTableVersion14)
Sheets("Category_Sales").PivotTables("SalesCategory").PivotCache.Refresh
Sheets("Category_Sales").PivotTables("SalesCategory").SaveData = True
ActiveWorkbook.ShowPivotTableFieldList = False
Sheets("Category_Sales").Columns("A").Cells.HorizontalAlignment = xlHAlignLeft
Cells(10, 2).Select
SaveXls
End Sub
Sub LineColor(MaxLineNumber As Integer)
Dim CellId As Range
Dim k As Integer
Dim r As Integer
Dim oColor
' kolorowanie na czarno
Set oColor = Worksheets("Category_Sales").Range("A13:AV" & MaxLineNumber + 13)
For Each CellId In oColor.Cells
k = CellId.Column
r = CellId.Row
Cells(r, k).Font.Color = 1
Cells(r, k).Font.Bold = False
Next CellId
Set oColor = Worksheets("Category_Sales").Range("A13:A" & MaxLineNumber + 13)
For Each CellId In oColor.Cells
k = CellId.Column
r = CellId.Row
 If Cells(r, 64).Value = "-1" Then 'Store Sales
 Range("A" & r & ":AV" & r).Interior.Color = RGB(204, 255, 204)
 Range("A" & r & ":AV" & r).Font.Bold = True
 ElseIf Cells(r, 64).Value = Cells(r, 65).Value And Cells(r, 65).Value = Cells(r, 66).Value And Cells(r, 64) <> "" Then 'Core Element
 Range("A" & r & ":AV" & r).Interior.Color = RGB(214, 225, 238)
 Range("A" & r & ":AV" & r).Font.Bold = True
 ElseIf Cells(r, 64).Value <> Cells(r, 65).Value And Cells(r, 65).Value = Cells(r, 66).Value Then 'Category
 Range("A" & r & ":AV" & r).Interior.Color = RGB(255, 255, 204)
 ElseIf Cells(r, 65).Value <> Cells(r, 66).Value And Cells(r, 66).Value = Cells(r, 67).Value Then 'Subcategory
 Range("A" & r & ":AV" & r).Interior.Color = RGB(191, 191, 191)
 ElseIf Cells(r, 66).Value <> Cells(r, 67).Value And Cells(r, 67).Value = Cells(r, 68).Value Then 'BMC
 Range("A" & r & ":AV" & r).Interior.Color = RGB(217, 217, 217)
 Else
 Range("A" & r & ":AV" & r).Interior.Color = xlNone 'Product
 End If
Next CellId
End Sub
Sub SaveXls()
Dim ReportPath As String
Dim ReportName As String
 Workbooks("MPF_NL_CategorySales.xlsm").Sheets("Category_Sales").Activate
 ReportPath = "E:\Reports_DART\Temp"
 Application.DisplayAlerts = False
 Sheets("Data_Load").Delete
 Sheets("Headers").Delete
 ActiveWorkbook.SaveAs Filename:= _
 ReportPath & "\MPF_Weekly_CategorySales_" & ReportWeek & ".xlsb", FileFormat:= _
 xlExcel12, CreateBackup:=False
 Application.Quit
 Application.DisplayAlerts = True
End Sub
Sub LineGroup(MaxLineNumber As Integer)
Dim CellId As Range
Dim k As Integer
Dim r As Integer
Dim oColor
Worksheets("Category_Sales").Activate
Rows("5:" & MaxLineNumber + 5).Select
Selection.ClearOutline
'
k = 13
Set oColor = Worksheets("Category_Sales").Range("A13:A" & MaxLineNumber + 13)
For Each CellId In oColor.Cells
r = CellId.Row
 If Cells(r, 64).Value = "-1" Then
 k = k + 1
 ElseIf Cells(r, 64).Value <> Cells(r + 1, 64).Value And Cells(r, 64).Value <> "" Then
 Rows(k & ":" & r - 1).Rows.Group
 k = r + 1
 End If
Next CellId
k = 13
Set oColor = Worksheets("Category_Sales").Range("A13:A" & MaxLineNumber + 13)
For Each CellId In oColor.Cells
r = CellId.Row
 If Cells(r, 65).Value = Cells(r, 64).Value Then
 k = k + 1
 ElseIf Cells(r, 65).Value <> Cells(r + 1, 65).Value And Cells(r, 65).Value <> "" Then
 Rows(k & ":" & r - 1).Rows.Group
 k = r + 1
 End If
Next CellId
'
k = 13
Set oColor = Worksheets("Category_Sales").Range("A13:A" & MaxLineNumber + 13)
For Each CellId In oColor.Cells
r = CellId.Row
 If Cells(r, 66).Value = Cells(r, 65).Value Then
 k = k + 1
 ElseIf Cells(r, 66).Value <> Cells(r + 1, 66).Value And Cells(r, 66).Value <> "" Then
 Rows(k & ":" & r - 1).Rows.Group
 k = r + 1
 End If
Next CellId
'
k = 13
Set oColor = Worksheets("Category_Sales").Range("A13:A" & MaxLineNumber + 13)
For Each CellId In oColor.Cells
r = CellId.Row
 If Cells(r, 67).Value = Cells(r, 66).Value Then
 k = k + 1
 ElseIf Cells(r, 67).Value <> Cells(r + 1, 67).Value And Cells(r, 67).Value <> "" Then
 Rows(k & ":" & r - 1).Rows.Group
 k = r + 1
 End If
Next CellId
'
Sheets("Category_Sales").Outline.ShowLevels RowLevels:=6
Sheets("Category_Sales").Outline.ShowLevels RowLevels:=5
Sheets("Category_Sales").Outline.ShowLevels RowLevels:=4
Sheets("Category_Sales").Outline.ShowLevels RowLevels:=3
Sheets("Category_Sales").Outline.ShowLevels RowLevels:=2
Sheets("Category_Sales").Outline.ShowLevels RowLevels:=1
'
End Sub
Sub Load_Data()
Sheets("Data_Load").Select
Range("A2").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Sheets("Headers").Select
Range("A2").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Range("A24").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
End Sub

Unfortunately, I cannot send you this report since it contains real prod data.

• Rdster: In LineColor, you declare and set a value for k...but you never use it. Removing the Selects, and qualifying your references will help speed it up a tad. stackoverflow.com/questions/10714251/…
• Tolani: @Rdster This sounds more like an answer than a comment.
• Rdster: @TolaniJaiye-Tikolo Very true, but Ballsy26 produced a much better answer.

Answer 1

Some easy changes to make

Disable Stuff

copied from https://stackoverflow.com/questions/12391786/effect-of-screen-updating

Sub YourSub()
 On Error GoTo EH
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = False
 ' Code here
 CleanUp:
 On Error Resume Next
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True
 Exit Sub
EH:
 ' Do error handling
 GoTo CleanUp
End Sub

Removing .select

In Load_Data you use a few unnecessary selections, these slow down code

Sheets("Data_Load").Select
Range("A2").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False

these can be changed to remove some unnecessary parts

Sheets("Data_Load").Range("A2").ListObject.QueryTable.Refresh BackgroundQuery:=False

in general where you use .select followed by selection. you can remove the .select and selection. and join the 2 parts together

Columns("BL:BP").Select 'kasowanie pól z GMH
Selection.Delete

becomes

Columns("BL:BP").Delete 'kasowanie pól z GMH

Use With ... End With

here you use the full statement to get to the same pivot table each time

ActiveSheet.PivotTables("SalesCategory").PivotFields("CoreElementCode").Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("CategoryCode").Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("SubcategoryCode").Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("BMCCode").Orientation = xlHidden
ActiveSheet.PivotTables("SalesCategory").PivotFields("ProductID").Orientation = xlHidden

this can be simplified to, including using the actual sheet name

With Sheets("Category_Sales").PivotTables("SalesCategory")
 .PivotFields("CoreElementCode").Orientation = xlHidden
 .PivotFields("CategoryCode").Orientation = xlHidden
 .PivotFields("SubcategoryCode").Orientation = xlHidden
 .PivotFields("BMCCode").Orientation = xlHidden
 .PivotFields("ProductID").Orientation = xlHidden
End With