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.

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/… — Rdster, Commented Dec 1, 2016 at 13:50
@TolaniJaiye-Tikolo Very true, but Ballsy26 produced a much better answer. — Rdster, Commented Dec 2, 2016 at 14:12

Community · Accepted Answer · 2017-05-23 12:41:02Z

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

Stack Exchange Network

Optimizing large Excel report

1 Answer 1

Your Answer

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.

Hot Network Questions

Optimizing large Excel report

1 Answer 1

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged performancevbaexcel or ask your own question.

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.