Delete hidden rows *runs slowly* [VBA]

[Martin_H]

Hi,

I am using this code to copy data from workbook_data and paste it into workbook_master (see below).

Then I filter out all unnecessary data.

Then I delete all hidden rows (the rows I filtered out in previous step).

Now, the problem is that it takes a while to complete the last step (see the code below -> 'Delete hidden rows)

Would it be possible to somehow speed up the last part?

Thank you.

'Open workbook_data
Workbooks.Open ("address")

'Copy data from workbook_data, from worksheet data
Workbooks("workbook_data.xlsx").Sheets("data").Range("A1", Range("H" & Rows.count).End(xlUp)).Copy

'Paste copied data inside workbook_master, inside worksheet master
Workbooks("workbook_master.xlsm").Sheets("master").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

'Close workbook_data without save
On Error Resume Next
Workbooks("workbook_data.xlsx").Close savechanges:=False
On Error GoTo 0

'Workbook_master with sheet master is now activated
'Filter the header in the range A1 based on values in the cells G4, H4 and I4 in the worksheet Sheet_X
ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=Array(Worksheets("Sheet_X").Range("G4").Value, Worksheets("Sheet_X").Range("H4").Value, Worksheets("Sheet_X").Range("I4").Value), Operator:=xlFilterValues

'Delete hidden rows
Dim sht As Worksheet
Dim lastrow
Set sht = ActiveSheet
lastrow = sht.UsedRange.Rows(sht.UsedRange.Rows.count).Row
For i = lastrow To 1 Step -1
If Rows(i).Hidden = True Then Rows(i).EntireRow.DELETE
Next

 

[veyselemre]

Try this.

Sub test()

    Dim flter(), lastCol&, lastRow&, rng As Range
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

    flter = Array( _
            Worksheets("Sheet_X").Range("G4").Value, _
            Worksheets("Sheet_X").Range("H4").Value, _
            Worksheets("Sheet_X").Range("I4").Value)

    ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=flter, Operator:=xlFilterValues

    lastCol = Cells(1, Columns.Count).End(1).Column + 1
    lastRow = Cells(Rows.Count, 1).End(3).Row

    Set rng = Range(Cells(2, lastCol + 1), Cells(lastRow, lastCol + 1))
    rng.Value = 1
    If WorksheetFunction.CountBlank(rng) > 0 Then
        rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        rng.Cells.ClearContents
    End If
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

End Sub

 

[Martin_H]

oops need to error trap if no hidden rows. otherwise it will hide all rows

On Error Resume Next

Dim lastrow
Set sht = ActiveSheet
lastrow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row

With Range("a1", Range("a" & lastrow))
    .SpecialCells(12).Select
    .Cells.EntireRow.Hidden = False
    Selection.EntireRow.Hidden = True
    .SpecialCells(12).EntireRow.Delete
    .Cells.EntireRow.Hidden = False
End With

On Error GoTo 0

Much better now!

Macro went from 22 seconds to less than 8 seconds

Thank you rpaulson.

 

[Martin_H]

Try this.

Sub test()

    Dim flter(), lastCol&, lastRow&, rng As Range
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

    flter = Array( _
            Worksheets("Sheet_X").Range("G4").Value, _
            Worksheets("Sheet_X").Range("H4").Value, _
            Worksheets("Sheet_X").Range("I4").Value)

    ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=flter, Operator:=xlFilterValues

    lastCol = Cells(1, Columns.Count).End(1).Column + 1
    lastRow = Cells(Rows.Count, 1).End(3).Row

    Set rng = Range(Cells(2, lastCol + 1), Cells(lastRow, lastCol + 1))
    rng.Value = 1
    If WorksheetFunction.CountBlank(rng) > 0 Then
        rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        rng.Cells.ClearContents
    End If
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

End Sub

Hi Veyselemre.

Thank you for your solution.

It works well, it is hella quick, but there is a small problem.

Not sure why, but I am getting way more results than I should get from filter, from range G4, H4, I4 values

 

[veyselemre]

Hi, try this.

Sub test()

    Dim flter(), lastCol&, lastRow&, rng As Range
    If ActiveSheet.FilterMode Then ActiveSheet.AutoFilterMode = False
    lastRow = Cells(Rows.Count, 1).End(3).Row '******
    
    flter = Worksheets("Sheet_X").Range("G4:I4").Value '******
    
    ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=flter, Operator:=xlFilterValues

    lastCol = Cells(1, Columns.Count).End(1).Column + 1

    Set rng = Range(Cells(2, lastCol + 1), Cells(lastRow, lastCol + 1))
    rng.Value = 1
    If WorksheetFunction.CountBlank(rng) > 0 Then
        rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    rng.Cells.ClearContents '******
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

End Sub

 

[Martin_H]

Hi, try this.

Sub test()

    Dim flter(), lastCol&, lastRow&, rng As Range
    If ActiveSheet.FilterMode Then ActiveSheet.AutoFilterMode = False
    lastRow = Cells(Rows.Count, 1).End(3).Row '******
   
    flter = Worksheets("Sheet_X").Range("G4:I4").Value '******
   
    ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=flter, Operator:=xlFilterValues

    lastCol = Cells(1, Columns.Count).End(1).Column + 1

    Set rng = Range(Cells(2, lastCol + 1), Cells(lastRow, lastCol + 1))
    rng.Value = 1
    If WorksheetFunction.CountBlank(rng) > 0 Then
        rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    rng.Cells.ClearContents '******
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

End Sub

****, that is blazing fast!?

Thank you very much veyselemre. I appreciate it.