A faster alternative to .SpecialCells(xlCellTypeVisible).Copy

Question

I am looking for recommendations for a faster alternative to .SpecialCells(xlCellTypeVisible).Copy . I have a large set of data that needs to be filtered (<> "") and copied from one worksheet to another. I am doing this many times over many columns so it ends up taking more time than I'd like. I created a test workbook to see using just two columns and twenty rows. Here is the code I used for the test:

Sub Filter_and_PasteSpecial()

With Application
    .Calculation = xlManual: .ScreenUpdating = False: .DisplayStatusBar = False: .DisplayAlerts = False: .EnableEvents = False
End With

Dim ws As Worksheet, sh As Worksheet
Dim r As Range
Dim lr As Long
Dim StartTime As Double
Dim SecondsElapsed As Double

StartTime = Timer

Set ws = ThisWorkbook.Sheets("Sheet1")
Set sh = ThisWorkbook.Sheets("Sheet2")

On Error Resume Next
ws.ShowAllData

lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

Set r = ws.Range(Cells(1, 1), Cells(lr, 2))
r.AutoFilter field:=2, Criteria1:="<>"

ws.Range(Cells(2, 2), Cells(lr, 2)).SpecialCells(xlCellTypeVisible).Copy _
Destination:=sh.Range("B1")

With Application
    .Calculation = xlAutomatic: .ScreenUpdating = True: .DisplayStatusBar = True: .DisplayAlerts = True: .EnableEvents = True
End With

SecondsElapsed = (Timer - StartTime)
MsgBox "Done in " & SecondsElapsed, vbInformation


End Sub

This test code took my computer .119140625 seconds to run. Thank you.

Answer 1

This method should be a bit faster, showing about a 3x speedup, but not sure how much I'd trust my testing methods here. Try it out and see if this speeds up your program.

I'm dumping the range to an array, then iterating that array and removing the blank values.

Code

Sub Filter_and_PasteSpecial2()
    Dim Sheet1             As Excel.Worksheet
    Dim Sheet2             As Excel.Worksheet
    Dim CellArray          As Variant
    Dim filteredArray      As Variant
    Dim LastRow            As Long
    Dim StartTime          As Double: StartTime = Timer
    Dim i                  As Long
    Dim j                  As Long

    Set Sheet1 = ThisWorkbook.Worksheets("Sheet1")
    Set Sheet2 = ThisWorkbook.Worksheets("Sheet2")

    With Sheet1
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        CellArray = .Range(.Cells(1, 2), .Cells(LastRow, 2)).Value
    End With

    ReDim filteredArray(0 To UBound(CellArray))

    'Create a new array without blanks
    For i = LBound(CellArray, 1) To UBound(CellArray, 1)
        'Blanks show up as Empty
        If Not IsEmpty(CellArray(i, 1)) Then
            filteredArray(j) = CellArray(i, 1)
            j = j + 1
        End If
    Next

    'Dump the data to sheet 2
    Sheet2.Range("A1:A" & j - 1).Value = WorksheetFunction.Transpose(filteredArray)
    Debug.Print "New Method:      " & Timer - StartTime
End Sub

Results

Here are the times it took to run each program in seconds.

New Method:      0.01171875
Original method: 0.0390625