.SpecialCells（xlCellTypeVisible）.Copy的更快替代方法

Question

我正在尋找有關.SpecialCells(xlCellTypeVisible).Copy的更快替代方法的建議。 我有大量數據需要過濾（<>“”）並從一個工作表復制到另一個工作表。 我在許多專欄文章中都做了很多次，所以最終花費的時間比我想要的更多。 我創建了一個測試工作簿，以查看僅使用兩列和二十行。 這是我用於測試的代碼：

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

此測試代碼使我的計算機運行了0.119140625秒。 謝謝。

Answer 1

這種方法應該更快一些，顯示出大約3倍的加速，但是不確定在這里我有多信任我的測試方法。 嘗試一下，看看是否可以加快程序速度。

我將范圍轉儲到數組中，然后對該數組進行迭代並刪除空白值。

碼

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

結果

這是在幾秒鍾內運行每個程序所花費的時間。

New Method:      0.01171875
Original method: 0.0390625