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.

Do realize that `ws.Range(Cells(2, 2), Cells(lr, 2))` needs to be `ws.Range(ws.Cells(2, 2), ws.Cells(lr, 2))` or rely on the active sheet to be ws? See [Is the . in .Range necessary when defined by .Cells?](https://stackoverflow.com/questions/36368220/is-the-in-range-necessary-when-defined-by-cells) — , Feb 16 '18 at 15:04
`On Error Resume Next` Why? That is a red flag when used the way that you are using it (with no checking of `Err.Number` and no matching `On Error GoTo 0` to turn error-handling back on). — John Coleman, Feb 16 '18 at 15:06
@Jeeped if I were within the With ws could I simply use .cells? — Chris2015, Feb 16 '18 at 15:07
@Chris2015 - yes, that provides a proper parent worksheet reference. — , Feb 16 '18 at 15:08
@JohnColeman - .ShowAllData throws an error if no filter is active on the worksheet. — , Feb 16 '18 at 15:09
@John Coleman I used On Error Resume Next because I have received an error when nothing is filtered — Chris2015, Feb 16 '18 at 15:12
Do you really need copy-paste or would just copying the values work? — Tim Williams, Feb 16 '18 at 17:12
I need to transfer the values from one worksheet to another without the blanks. I wonder if .value = .value and then remove blank rows on the second worksheet would be faster... — Chris2015, Feb 16 '18 at 17:13

score 0 · Accepted Answer · answered Feb 16 '18 at 18:27

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

This worked much faster. Although I am having trouble replicating on my larger workbook. — Chris2015, Feb 16 '18 at 20:26
@Chris2015 what kind of trouble? Does it slow down the larger it gets? Problem with transposing? — Ryan Wildry, Feb 16 '18 at 20:53
I'm not sure honestly. I have the code within a loop. I think I have everything correct, but sometimes no data get placed back on my worksheet ("Sheet2"). Other times it is a single data point replication multiple times. — Chris2015, Feb 16 '18 at 20:58
`Worksheet.Transpose` can be problematic, I think it errors out if you have more than 255 characters in a cell. You can try manually transpose the array elements instead of calling that function. Here's a link to code that will do that. https://bettersolutions.com/vba/arrays/transposing.htm. Check to make sure the array only has one dimension too — Ryan Wildry, Feb 16 '18 at 21:14

A faster alternative to .SpecialCells(xlCellTypeVisible).Copy

1 Answers1