Question

我正在寻找更快替代.SpecialCells(xlCellTypeVisible).Copy的建议。我有大量数据需要过滤（＆lt;＆gt;＆＃34;＆＃34;）并从一个工作表复制到另一个工作表。我在很多专栏上做了很多次，所以最终花费的时间比我想要的多。我创建了一个测试工作簿，看看只使用了两列和二十行。这是我用于测试的代码：

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

此测试代码使用我的电脑.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

是.SpecialCells（xlCellTypeVisible）.Copy的更快替代品

1 个答案: