-1

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
Improve this question
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. 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. Commented Jan 30 at 2:41

2 Answers 2

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)

Improve this answer
Sign up to request clarification or add additional context in comments.

1 Comment

Thanks for the code update👍🏿
0

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
Improve this answer

1 Comment

Wow! Thanks bunch for the code update.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.