excel - Difficult to run - Stack Overflow

I have this code to hide and unhide the months this code is slow, how to improve it?

Sub jan1()

    Range("D2:ABG2").Copy
    Range("D1").PasteSpecial Paste:=xlPasteValues

    Range("D1:ABG1").Value = Range("D1:ABG1").Value

    Range("D1:ABG1").Select

    With Selection.Font

        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0

        Application.CutCopyMode = False

        Dim cell As Range

        For Each cell In ActiveWorkbook.ActiveSheet.Rows("1").Cells
            If cell.Value = "1" Then
                cell.EntireColumn.Hidden = True
            End If
        Next cell

        Range("C1").Select

    End With

End Sub

I have this code to hide and unhide the months this code is slow, how to improve it?

Sub jan1()

    Range("D2:ABG2").Copy
    Range("D1").PasteSpecial Paste:=xlPasteValues

    Range("D1:ABG1").Value = Range("D1:ABG1").Value

    Range("D1:ABG1").Select

    With Selection.Font

        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0

        Application.CutCopyMode = False

        Dim cell As Range

        For Each cell In ActiveWorkbook.ActiveSheet.Rows("1").Cells
            If cell.Value = "1" Then
                cell.EntireColumn.Hidden = True
            End If
        Next cell

        Range("C1").Select

    End With

End Sub

• excel
• vba
• windows
• hide
• monthcalendar

Share Improve this question Follow asked Jan 30 at 1:57 Célio GonçalvesCélio Gonçalves 1322 bronze badges 2

• 1 Setting Application.Sreenupdating = False should speed things up. You also don’t need to check every cell in that row, only the used part. – Tim Williams Commented Jan 30 at 1:59
• 2 If you have working code, and you are primarily seeking ways to improve performance or ensure that you're following best practices, your question may be better suited to the Code Review Stack Exchange site, which encourages open-ended suggestions for code improvements. Before posting there, please ensure that your question is well-formatted, as they have slightly different posting guidelines than Stack Overflow. – Hoppeduppeanut Commented Jan 30 at 2:41

Add a comment  | 

2 Answers 2

Sorted by: Reset to default 0

Use Intersect to obtain the used range in the first row, eliminating the need for the script to check each cell in row 1.

Sub jan1()
    Dim oSht1 As Worksheet
    Application.ScreenUpdating = True
    Set oSht1 = Sheets("Sheet1")  ' modify sheet name as needed
    oSht1.Cells.EntireColumn.Hidden = False
    ' copy value to the 1st row
    oSht1.Range("D1:ABG1").Value = oSht1.Range("D2:ABG2").Value
    With oSht1.Range("D1:ABG1").Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Dim cell As Range, rng As Range, rHide As Range
    ' get the used range in the 1st row (shrink target range to improve the efficiency)
    Set rng = Application.Intersect(oSht1.Rows(1), oSht1.UsedRange)
    Const START_COL = 4 ' only hidden columns after Col D 
    For Each cell In rng.Cells
        If cell.Column >= START_COL Then
            If cell.Value = "1" Then
                ' get the first cell of hidden columns
                If rHide Is Nothing Then
                    Set rHide = cell
                Else
                    Set rHide = Application.Union(rHide, cell)
                End If
            End If
        End If
    Next cell
    If Not rHide Is Nothing Then rHide.EntireColumn.Hidden = True
    Application.ScreenUpdating = False
End Sub

Microsoft documentation:

Application.Intersect method (Excel)

Application.Union method (Excel)

Show (UnHide) Matching Columns

Usage

Sub ShowJan()
    ShowMonth 1 ' maybe "1"?
End Sub

The Method

Sub ShowMonth(ByVal MonthToShow As Variant)
    
    ' Define constants.
    Const PASTE_RANGE_ADDRESS As String = "D1:ABG1"
    Const COPY_ROW_OFFSET As Long = 1
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the range.
    Dim rg As Range: Set rg = ws.Range(PASTE_RANGE_ADDRESS)
    
    ' Return 1 for each matching column in a 1D one-based array.
    Dim ColumnIndices() As Variant
    With rg
        ' Copy values (from the row below).
        .Value = .Offset(COPY_ROW_OFFSET).Value
        ' Format font.
        With .Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        ' Match columns.
        ColumnIndices = Application.Match(.Cells, Array(MonthToShow), 0)
    End With
    
    ' Loop through the array and for all values equaling 1
    ' (not equaling an error), add the corresponding cell to a unioned range.
    Dim urg As Range, c As Long
    For c = 1 To UBound(ColumnIndices)
        If IsNumeric(ColumnIndices(c)) Then
            If urg Is Nothing Then
                Set urg = rg.Cells(c)
            Else
                Set urg = Union(urg, rg.Cells(c))
            End If
        End If
    Next c
    
    ' Hide all entire columns of the range.
    rg.EntireColumn.Hidden = True
    
    ' Show the matching columns.
    If urg Is Nothing Then
        MsgBox "No columns for month " & MonthToShow & "!", vbExclamation
    Else
        urg.EntireColumn.Hidden = False
        MsgBox "Showing columns for month " & MonthToShow & ".", vbInformation
    End If

End Sub