[英]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.