Question

我正在处理一些非常大的数据集（各种表格，每行65K +行，每列很多）。我正在尝试编写一些代码，以尽可能快地将过滤后的数据从一个工作表复制到一个新的空工作表，但到目前为止还没有取得多大成功。

我可以按请求包含其余代码，但它所做的只是计算源和目标范围（srcRange和destRange）。计算这些的时间可以忽略不计。绝大部分时间都花在这条线上（确切地说是4分50秒）：

srcRange.Rows.SpecialCells(xlCellTypeVisible).Copy Destination:=destRange

此外，我已经尝试过这个：

destRange.Value = srcRange.Rows.SpecialCells(xlCellTypeVisible).Value

但是当有过滤器时，它无法正常工作。

Function FastCopy(srcSheet As String, srcCol As String, destSheet As String, destCol As String)

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim srcRange As Range
    Dim destRange As Range

    Set srcRange = GetColumnRangeByHeaderName(srcSheet, srcCol, -1)
    Set destRange = GetColumnRangeByHeaderName(destSheet, destCol, srcRange.Rows.Count)


    'destRange.Value = srcRange.Rows.SpecialCells(xlCellTypeVisible).Value

    srcRange.Rows.SpecialCells(xlCellTypeVisible).Copy Destination:=destRange

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
End Function

这是一款速度较慢的双核机器，运行excel 2010时运行2GB内存。结果显然会在更快的机器上发生变化。

Answer 1

尝试这样的方法来处理过滤范围。你处于正确的轨道上，.Copy方法很昂贵，只需将范围内的值写得更快，但是正如您所观察到的，当过滤范围时，这不起作用。过滤范围后，您需要迭代范围.Areas中的.SpecialCells：

Sub Test()
Dim rng As Range
Dim subRng As Range
Dim destRng As Range


Set destRng = Range("A10")

Set rng = Range("A1:B8").SpecialCells(xlCellTypeVisible)

For Each subRng In rng.Areas
    Set destRng = destRng.Resize(subRng.Rows.Count, subRng.Columns.Count)
    destRng.Value = subRng.Value
    Set destRng = destRng.Cells(destRng.Rows.Count, 1).Resize(1, 1).Offset(1, 0)
Next

End Sub

为您的目的而修改，但未经测试：

Function FastCopy(srcSheet As String, srcCol As String, destSheet As String, destCol As String)

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim srcRange As Range
    Dim destRange As Range
    Dim subRng As Range

    Set srcRange = GetColumnRangeByHeaderName(srcSheet, srcCol, -1)
    Set destRange = GetColumnRangeByHeaderName(destSheet, destCol, srcRange.Rows.Count)

    For Each subRng In srcRange.Areas
        Set destRng = destRng.Resize(subRng.Rows.Count, subRng.Columns.Count)
        destRng.Value = subRng.Value
        Set destRng = destRng.Cells(destRng.Rows.Count, 1).Resize(1, 1).Offset(1, 0)
    Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
End Function

Answer 2

最简单的复制（无过滤器）

Range("F1:F53639").Value = Range("A1:A53639").Value

扩展我的评论

Sub Main()
Application.ScreenUpdating = False
    ' paste the Range into an array
    Dim arr
    arr = Range("$A$1:$A$53639").Value

    ' fill the range based on the array
    Range("$F$1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr


    ' apply the same filter to your copied range as the original range
        '+  i don't know how you have applied your filter but just re-apply it to column F

    ' and delete the invisible cells
    ' unfortunately there is no xlCellTypeHidden or xlCelltypeInvisible hehe so you have to iterate
    Dim i As Long
    For i = Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
        If (Range("F" & i).EntireRow.Hidden) Then Range("F" & i).Delete
        ' or Range("F" & i).EntireRow.Delete
    Next i
Application.ScreenUpdating = True
End Sub

如果你可以提供你运行它的时间，这将是非常好的我非常好奇

我刚刚在53639行上运行此代码，花了不到1秒

Sub Main()
Application.ScreenUpdating = False

    Dim tNow As Date
    tNow = Now

    ' paste the Range into an array
    Dim arr
    arr = Range("$A$1:$A$53639").Value

    ' fill the range based on the array
    Range("$F$1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

    ' apply the same filter to your copied range as the original range
    ActiveSheet.Range("$F$1:$F$53640").AutoFilter Field:=1, Criteria1:="a"

    ' and delete the invisible cells
    ' unfortunately there is no xlCellTypeHidden or xlCelltypeInvisible hehe so you have to iterate
    Dim i As Long
    For i = Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
        If (Range("F" & i).EntireRow.Hidden = True) Then
            Range("F" & i).Delete
        End If
    Next i

    Debug.Print DateDiff("s", tNow, Now)
Application.ScreenUpdating = True
End Sub

在excel中有效地复制可见/已过滤的行

2 个答案: