Question

我正在尝试将一个范围从一张纸复制到另一张纸，但忽略空白行，并确保目标中没有空白行。

在该网站上浏览后，我已经成功使用了下面的代码。

但是，我想将其扩展到较大的数据范围，这似乎需要一个绝对年龄。关于更有效的代码有什么想法吗？这里是新手！

谢谢！

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim Source As Worksheet
Dim Destination As Worksheet
Dim i As Integer
Dim j As Integer

Set Source = Sheet1
Set Destination = Sheet4

j = 2
For i = 9 To 10000
    If Source.Cells(i, 2).Value <> "" Then
        Destination.Cells(j, 1).Value = Source.Cells(i, 1).Value
        Destination.Cells(j, 2).Value = Source.Cells(i, 2).Value
        Destination.Cells(j, 3).Value = Source.Cells(i, 3).Value
        Destination.Cells(j, 4).Value = Source.Cells(i, 4).Value
        Destination.Cells(j, 5).Value = Source.Cells(i, 5).Value
        Destination.Cells(j, 6).Value = Source.Cells(i, 6).Value
        Destination.Cells(j, 7).Value = Source.Cells(i, 7).Value
        Destination.Cells(j, 8).Value = Source.Cells(i, 8).Value
        Destination.Cells(j, 9).Value = Source.Cells(i, 9).Value
        j = j + 1
    End If
Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic

End Sub

[编辑后更加清晰]

Answer 1

用下面的代码替换您的for循环。

方法1：合并所有要复制的范围，然后一次粘贴它们。

    Dim copyRange As Range

    For i = 9 To 10000
        If Source.Cells(i, 2).Value <> "" Then
            If copyRange Is Nothing Then
                Set copyRange = Source.Range(Source.Cells(i, 1), Source.Cells(i, 9))
            Else
                Set copyRange = Union(copyRange, Source.Range(Source.Cells(i, 1), Source.Cells(i, 9)))
            End If
        End If
    Next i

    copyRange.Copy Destination.Cells(2, 1)

方法2（推荐）：使用自动过滤器过滤数据。

    Dim sourceRng As Range
    Set sourceRng = Source.Range(Source.Cells(9, 1), Source.Cells(10000, 9))

    sourceRng.AutoFilter Field:=2, Criteria1:="<>"
    sourceRng.Copy Destination.Cells(2, 1)
    Source.AutoFilterMode = False

Answer 2

遍历工作表行几乎是处理数据块的最慢方法。唯一慢的是遍历行和列。

我不确定您有多少条记录，但这在约0.14秒内处理了1500行虚拟数据。

Option Explicit

Sub Macro4()

    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim i As Long, j As Long, k As Long, arr As Variant

    On Error GoTo safe_exit
    appTGGL bTGGL:=False

    Set wsSource = Sheet1
    Set wsDestination = Sheet4

    'collect values from Sheet1 into array
    With wsSource
        arr = .Range(.Cells(9, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 7)).Value
    End With

    'find first blank in column B
    For j = LBound(arr, 1) To UBound(arr, 1)
        If arr(j, 2) = vbNullString Then Exit For
    Next j

    'collect A:I where B not blank
    For i = j To UBound(arr, 1)
        If arr(i, 2) <> vbNullString Then
            For k = 1 To 9: arr(j, k) = arr(i, k): Next k
            j = j + 1
        End If
    Next i

    'clear remaining rows
    For i = j To UBound(arr, 1)
        For k = 1 To 9: arr(i, k) = vbNullString: Next k
    Next i

    'put values sans blanks into Sheet4
    With wsDestination
        .Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

safe_exit:
    appTGGL

End Sub

Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .EnableEvents = bTGGL
        .ScreenUpdating = bTGGL
        .DisplayAlerts = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    End With
    Debug.Print IIf(bTGGL, "end: ", "start: ") & Timer
End Sub

从一个范围复制到另一个忽略空格（Excel）

2 个答案: