Increasing For Next Loop speed-CodePudding

I have a variable number of data sets - where each data set consists of 12 rows that has info on a specific stock item with a summary in the uppermost row of each row set. Two ribbon buttons then collapse or expand the data sets.

The expand Sub is pretty simple by selecting the entire range and unhiding any hidden rows. The collapse sub however takes a much longer time to run on 1000 rows.

Helper column B (normally hidden) has the letter C (for Collapse) in all rows except the first row in the set of 12 rows. The code below then runs through Column B and hides all the rows containing C - this leaves only the upper row of all the data sets - so you get an overview of all items in the variable range.

I thought of using a Filter on Column B (for "C") and hiding the resulting visible rows but I can't get that code working. It doesn't hide anything when the filter is removed at the end.

Any thoughts of speeding up the code, or an alternative method?

Dim rng As Range, Cell As Range
Dim Row As Integer, Lastrow As Integer

    Lastrow = Sheets("Sheet1").UsedRange.Rows.Count
    Set rng = Sheets("Sheet1").Range("B19:B" & Lastrow)
    
    On Error Resume Next
        For Each Cell In rng
            If Cell = "C" Then
                    Row = Cell.Row
                    Sheets("Sheet1").Rows(Row).EntireRow.Hidden = True
                Else
            End If
        Next Cell

CodePudding user response：

Collapse (Hide) Criteria Rows Using `AutoFilter`

Sub CollapseRows()
    
    Const wsName As String = "Sheet1"
    Const HeaderRow As Long = 18
    Const CriteriaColumn As String = "B"
    Const Criteria As String = "C"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    If ws.FilterMode Then ws.ShowAllData
    
    Dim rgTable As Range ' has headers
    
    With ws.Columns(CriteriaColumn)
        If .Hidden = True Then .Hidden = False
        Dim lCell As Range: Set lCell = .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub ' empty column
        If lCell.Row <= HeaderRow Then Exit Sub ' only headers or empty below
        Set rgTable = .Resize(lCell.Row - HeaderRow   1).Offset(HeaderRow - 1)
    End With
        
    Dim rgData As Range ' no headers
    Set rgData = rgTable.Resize(rgTable.Rows.Count - 1).Offset(1)
    
    rgTable.AutoFilter 1, Criteria
        
    Dim rgVisible As Range
    On Error Resume Next
        Set rgVisible = rgData.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    ws.AutoFilterMode = False
    
    If Not rgVisible Is Nothing Then
        rgVisible.EntireRow.Hidden = True
    'Else ' no criteria rows; do nothing
    End If
    
    ws.Columns(CriteriaColumn).Hidden = True
         
End Sub

CodePudding user response：

I have the standard lines to disable screen updating, but I'll have to try the "Union" suggestion.

In the meantime, since the data set is always 12 rows, the data is consistent, so this code runs about 12 times faster since it only checks every 12th row, hides the following 11 rows, and steps ahead by 12 rows to check again.

the number 18 is just the rows at the top of the sheet.

    Dim Row As Integer, Lastrow As Integer
    Dim Module As Integer
    
        Lastrow = Sheets("Sheet1").UsedRange.Rows.Count
        Module = (Lastrow - 18) / 12
        Module_ = 19   (Module * 12) - 12
        
            For i = 19 To Module_ Step 12
                Sheets("Sheet1").Range("A" & (i   1) & ":AC" & (i   11)).EntireRow.Hidden = True
            Next i

Collapse (Hide) Criteria Rows Using AutoFilter

Collapse (Hide) Criteria Rows Using `AutoFilter`