简体   繁体   English

.SpecialCells(xlCellTypeVisible).Copy的更快替代方法

[英]A faster alternative to .SpecialCells(xlCellTypeVisible).Copy

I am looking for recommendations for a faster alternative to .SpecialCells(xlCellTypeVisible).Copy . 我正在寻找有关.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. 此测试代码使我的计算机运行了0.119140625秒。 Thank you. 谢谢。

This method should be a bit faster, showing about a 3x speedup, but not sure how much I'd trust my testing methods here. 这种方法应该更快一些,显示出大约3倍的加速,但是不确定在这里我有多信任我的测试方法。 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

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM