To improve code speed - drill down options on excel

tulip_ad · Mar 7th 2020

Hi All,

Great forum with plenty of help and thank you all for being active as your input is quite often valuable and useful. It came a time when I thought to get your view on my work and some performance problem I deal with i.e. time of macro being run.
I developed a sheet that shows top level values and when pointing on '+' sign it drills into details of that value (while in reality it does execute another macro to provide details - based on advanced filtering) all runs ok no issues but due to data size it is a little slower than I would expect i.e. on average 14 seconds per drill down. I have tried to streamline code where possible and also switched off additional functions when macro run but it resulted in improvement from 17 seconds to 13 seconds only. Would that be max I can get from it. Or is there anything else I could improve to get to a better execution time. To note there are just over 20k rows to deal with at any time from the data I filter.

To support it see first code for calling '+' action and then below second for getting into drilling mode

Code

Option Explicit
Dim PageBreakState As Boolean

Sub Worksheet_SelectionChange(ByVal Target As Range)
'Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C3:C100")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
If Target.Value = "+" And Range("P" & Target.Row).Value = "C" Then 'Show Invoices
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False
    'Application.DisplayStatusBar = False
    Show_Details_Top_Level
    End
End If
If Target.Value = "-" And Range("P" & Target.Row).Value = "C" Then 'Hide Invoices
    Hide_Details_Top_Level
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    'Application.DisplayStatusBar = True
    'PageBreakState = ActiveSheet.DisplayPageBreaks
    'ActiveSheet.DisplayPageBreaks = True
    End
End If
If Target.Value = "+" And Range("P" & Target.Row).Value = "N" Then 'Show Transactions
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Show_Transactions_Top_Level
    End
End If
If Target.Value = "-" And Range("P" & Target.Row).Value = "N" Then 'Hide Transactions
    Hide_Transactions_Top_Level
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    End
End If
End If



End Sub

Display More

Second part to execute ShowTopLevel macro

Code

Option Explicit

Dim Directorate As String, MA_Des As String
Dim DirectorateQty As Long, LastDirectorateRow As Long, LastFiltRow As Long, ActRow As Long

Sub Show_Details_Top_Level()
    With Sheet1
        ActRow = ActiveCell.Row
        Directorate = .Range("A" & ActRow).Value 'Get Directorate #
        MA_Des = "*" & .Range("B" & ActRow).Value & "*" 'Get Details #
        Sheet1.Range("F7:G7").Copy Destination:=Sheet3.Range("HC4:HD4") 'Paste period for data
        Sheet3.Range("GG1:GL1").Value = Sheet3.Range("HE4:HJ4").Value 'Paste Top Level Calcs#
        Sheet3.Range("GM1").Value = Sheet3.Range("HL4").Value 'Paste Top Level Calcs#
        LastDirectorateRow = Sheet3.Range("B20999").End(xlUp).Row 'Get last Row of Directorate
        Sheet3.Range("HA2:OV2,HA5:HL999").ClearContents 'Clear any previous data
        Sheet3.Range("HB2").Value = Directorate
        Sheet3.Range("II2").Value = MA_Des
        Sheet3.Range("ON2").Value = "Yes"
        Sheet3.Range("A1:GV" & LastDirectorateRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet3.Range("HA1:OV2"), CopyToRange:=Sheet3.Range("HA4:HL4"), Unique:=True
        LastFiltRow = Sheet3.Range("HA999").End(xlUp).Row 'Last FilterRow
        If LastFiltRow < 5 Then GoTo NoDirectorate
            DirectorateQty = LastFiltRow - 4 'Get The Number Of Directorate Lines
            ActiveCell.Value = "-"
            ActiveCell.EntireRow.Offset(1).Resize(DirectorateQty + 1).Insert Shift:=xlDown 'Inserts # of Ros + 1 for Header
            With Range("D" & ActRow + 1 & ":P" & ActRow + 1)
                .Value = .Range("AA2:AM2").Value 'Add Nominal Header
                .HorizontalAlignment = xlCenter 'Justify Center Nominal Header
            End With
       End If
        With Range("F" & ActRow + 1 & ":O" & ActRow + 1)
            .HorizontalAlignment = xlCenter 'Justify Centre Nominal Header
            .VerticalAlignment = xlBottom 'Justify Center Nominals Header
            .WrapText = True ' Cells wrap
       End With
    With Range("C" & ActRow + 2 & ":C" & ActRow + 1 + DirectorateQty)
        .Value = "+" 'Mark Line as Expand For Payment
        .NumberFormat = "General" 'Format Invoice Numbers
    End With
    .Range("D" & ActRow + 2 & ":P" & ActRow + 1 + DirectorateQty).Value = Sheet3.Range("HA5:HL" & LastFiltRow).Value 'Add Details
    .Range("D" & ActRow + 1 & ":E" & ActRow + 1 + DirectorateQty).Columns.AutoFit 'Column autofit
    .Range("O" & ActRow + 2 & ":O" & ActRow + 1 + DirectorateQty).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)" ' Format Amounts
    .Range("L" & ActRow + 2 & ":L" & ActRow + 1 + DirectorateQty).Style = "Percent" 'Format Amounts
    With Range("P" & ActRow + 2 & ":P" & ActRow + 1 + DirectorateQty)
        .Value = "N" 'Mark Line as Nominal
        .HorizontalAlignment = xlCenter ' Category Column Justify Centre
        .NumberFormat = "General" 'Format Category Column
    End With
End With
Exit Sub

NoDirectorate:
MsgBox "There are no Details for this line"
End Sub



Sub Hide_Details_Top_Level()
    With Sheet1
        ActRow = ActiveCell.Row
        LastDirectorateRow = ActiveCell.Offset(1, -1).End(xlDown).Row - 1
        ActiveCell.Value = "+"
        .Range(ActRow + 1 & ":" & LastDirectorateRow).EntireRow.Delete
        .Range("F" & ActRow + 1 & ":O" & ActRow + 9999).ColumnWidth = 11.22 'Column autofit
        Columns("D:E").Hidden = True 'Hide columns with Nominals and Description
    End With
End Sub

Display More

Please advise what I can do extra to make it better.

Really appreciate it.

tulip_ad · Mar 7th 2020

I have just noticed few little errors but no issue on running macro in that format.

I just changed value to value2 to speed it up and got extra few seconds because of it

**KjBox** · Mar 7th 2020

Hi, welcome to Ozgrid!

When posting code you must place it in a "Code box". To do so, copy your code, then click the "</>" icon in the reply box menu bar, and paste code into the code box that will appear. I have done this for you in this instance.

As for your code.

Using "If......ElseIf.......End If" statements is far more than separate "If.....End If" statements even with End in each If statement, but better still is "Select Case.....Case....End Select"

I have modified your first code to use Select case

Code

Option Explicit
Dim PageBreakState As Boolean

Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C3:C100")) Is Nothing Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        PageBreakState = ActiveSheet.DisplayPageBreaks
        ActiveSheet.DisplayPageBreaks = False
        Select Case Target.Value2
            Case "+"
                Select Case Cells(Target.Row, 16).Value2
                    Case "C": Show_Details_Top_Level Target.Row
                    Case "N": Show_Transactions_Top_Level Target.Row
                End Select
            Case "-"
                Select Case Cells(Target.Row, 16).Value2
                    Case "C": Hide_Details_Top_Level Target.Row
                    Case "N": Hide_Transactions_Top_Level Target.Row
                End Select
            End Select
        End Select
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        ActiveSheet.DisplayPageBreaks = PageBreakState
    End If
    
End Sub

Display More

You can parse the required row into your other two codes by using Target.Row so there is no need to use ActRow = ActiveCell.Row.

I have done that and improved your "With.....End With" statements. Further improvements could well be possible but I would need to see your workbook to know for sure.

Code

Option Explicit

Dim Directorate As String, MA_Des As String
Dim DirectorateQty As Long, LastDirectorateRow As Long

Public Sub Show_Details_Top_Level(lRow As Long)
    
    With Sheet1
        Directorate = .Range("A" & lRow).Value2 'Get Directorate #
        MA_Des = "*" & .Range("B" & lRow).Value2 & "*" 'Get Details #
    
        .Range("F7:G7").Copy Sheet3.Range("HC4:HD4") 'Paste period for data
        With Sheet3
            LastDirectorateRow = .Range("B20999").End(xlUp).Row 'Get last Row of Directorate
            DirectorateQty = .Range("HA999").End(xlUp).Row - 4 'Get The Number Of Directorate Lines
            
            .Range("GG1:GL1") = .Range("HE4:HJ4").Value 'Paste Top Level Calcs#
            .Range("GM1").Value = Sheet3.Range("HL4").Value 'Paste Top Level Calcs#
            .Range("HA2:OV2,HA5:HL999").ClearContents 'Clear any previous data
            .Range("HB2") = Directorate
            .Range("II2") = MA_Des
            .Range("ON2") = "Yes"
            .Range("A1:GV" & LastDirectorateRow).AdvancedFilter , xlFilterCopy, .Range("HA1:OV2"), .Range("HA4:HL4"), True
            If LastFiltRow < 5 Then GoTo NoDirectorate
                With ActiveCell
                    .Value = "-"
                    .EntireRow.Offset(1).Resize(DirectorateQty + 1).Insert Shift:=xlDown 'Inserts # of Rows + 1 for Header
                End With
            End If
        End With
        With Range("D" & lRow + 1 & ":P" & lRow + 1)
            .Value2 = .Range("AA2:AM2").Value2 'Add Nominal Header
            .HorizontalAlignment = xlCenter 'Justify Center Nominal Header
        End With
        With Range("F" & lRow + 1 & ":O" & lRow + 1)
            .HorizontalAlignment = xlCenter 'Justify Centre Nominal Header
            .VerticalAlignment = xlBottom 'Justify Center Nominals Header
            .WrapText = True ' Cells wrap
        End With
        With Range("C" & lRow + 2 & ":C" & lRow + 1 + DirectorateQty)
            .Value = "+" 'Mark Line as Expand For Payment
            .NumberFormat = "General" 'Format Invoice Numbers
        End With
        .Range("D" & lRow + 2 & ":P" & lRow + 1 + DirectorateQty).Value = Sheet3.Range("HA5:HL" & LastFiltRow).Value 'Add Details
        .Range("D" & lRow + 1 & ":E" & lRow + 1 + DirectorateQty).Columns.AutoFit 'Column autofit
        .Range("O" & lRow + 2 & ":O" & lRow + 1 + DirectorateQty).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)" ' Format Amounts
        .Range("L" & lRow + 2 & ":L" & lRow + 1 + DirectorateQty).Style = "Percent" 'Format Amounts
        With Range("P" & lRow + 2 & ":P" & lRow + 1 + DirectorateQty)
            .Value = "N" 'Mark Line as Nominal
            .HorizontalAlignment = xlCenter ' Category Column Justify Centre
            .NumberFormat = "General" 'Format Category Column
        End With
    End With
    Exit Sub
    
NoDirectorate:
    MsgBox "There are no Details for this line"

End Sub

Public Sub Hide_Details_Top_Level(lRow As Long)
    
    LastDirectorateRow = ActiveCell.Offset(1, -1).End(xlDown).Row - 1
    
    With Sheet1
        .Range(lRow + 1 & ":" & LastDirectorateRow).EntireRow.Delete
        .Range("F" & lRow + 1 & ":O" & lRow + 9999).ColumnWidth = 11.22 'Column autofit
    End With
    ActiveCell.Value = "+"
    Columns("D:E").Hidden = True 'Hide columns with Nominals and Description
 
End Sub

Display More

tulip_ad · Mar 7th 2020

KjBox,

thank you for info. Some useful additions especially around 'Case', certain order might not work with the overall workbook especially on manualcalc.

Initially tested but didn't work so need to verify it again. Too late today to think as was sitting on it from morning.

with end statement - spot on. I missed it somehow.

tulip_ad · Mar 7th 2020

I couldn't leave it so just grabbed a drink and got through case option - all works and squeezed the time in half (I didn't expect it to be so long for the initial call function). But I need to leave Target.Row for tomorrow as getting error again on call macro somehow or it doesn't call it at all

tulip_ad · Mar 8th 2020

Further note on Target.Row - no real improvement on macro timing on this occasion.

Overall after adding all data rows (21k rows) the time is just below 10 seconds overall. Not the best but definitively better than 17 seconds previously. 'Case' instead of 'If' option made a trick. I would need to rethink on the data itself to see what else can be done (perhaps through sql on data before hand)

**KjBox** · Mar 8th 2020

Didn't really expect Target.Row to make a difference in speed, it was just a better way of coding.

**KjBox** · Mar 8th 2020

If you are importing data from an external source then Power Query would be even better than SQL

To improve code speed - drill down options on excel

Participate now!

Share