Question

我编写了一个脚本，用于检查列范围4（列D）中的一系列单元格是否为非空值，如果找到非空值，则复制该值并将其粘贴到列范围6中的单元格（F栏）。该脚本运行，但速度非常慢，脚本需要5分钟来处理并完成其运行。有没有办法改进这个脚本，以便它可以在复制和粘贴值之前预先检查范围？似乎复制/粘贴功能正在减慢速度。

以下代码

Sub ArrayCopyPaste()
Dim J as Integer
Application.Calculation = xlCalculationManual

For J = 2 To 500
    If Cells(J, 4).Value <> "" Then
        Cells(J, 4).Copy
        Cells(J, 6).PasteSpecial Paste:=xlPasteValues
    End If
Next J

Application.Calculation = xlCalculationAutomatic
End Sub

Answer 1

以这种方式：

Sub test()
    Dim r1, r2, n As Long
    With Sheets("Sheet1") '~~> change to suit
        Dim lrow As Long
        lrow = .Range("D" & .Rows.Count).End(xlUp).Row
        r1 = Application.Transpose(.Range("D2:D" & lrow))
        r2 = Application.Transpose(.Range("F2:F" & lrow))
        For n = LBound(r1) To UBound(r1)
            If r1(n) <> "" Then r2(n) = r1(n)
        Next
        .Range("F2:F" & lrow) = Application.Transpose(r2)
    End With
End Sub

将范围数据传输到数组，然后将比较过程数组转换为数组然后将数组返回到范围。 HTH。

重要提示： Application.Transpose 有限制。我只能处理几千个数据。

跟进：请尝试删除

Dim rngToDelete As Range, k As Long

With Sheets("Sheet1") '~~> change to suit
    For k = 2 To 500
        If .Cells(k, 6).Value = "" Then
            If rngToDelete Is Nothing Then
                Set rngToDelete = .Cells(k, 6)
            Else
                Set rngToDelete = Union(rngToDelete, .Cells(k, 6))
            End If
        End If
    Next
    rngToDelete.Delete xlUp
    'rngToDelete.EntireRow.Delete xlUp ~~> use this if you want to delete entire row.
End With

首先确定所有目标范围，然后一次删除。 HTH。

Answer 2

首先尝试执行此操作，看看它是否有所作为：

Dim currentCalculation As Variant
currentCalculation = Application.Calculation
Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

For J = 2 To 500
    If Cells(J, 4).Value <> "" Then
        Cells(J, 4).Copy
        Cells(J, 6).PasteSpecial Paste:=xlPasteValues
    End If
Next J

Application.ScreenUpdating = True

Application.Calculation = currentCalculation

另一种想法。你试过这样做吗？

For J = 2 To 500
    If Cells(J, 4).Value <> "" Then
        Cells(J, 6).Value = Cells(J, 4).Value
    End If
Next J

Answer 3

如果空白被复制，它对您的目标列没有任何影响，因此请不要检查它们。 不要循环 - 只需复制整个列。

Sub CopyColumn()
    ' copying this way does not use your clipboard
    Columns("D").Copy Columns("F")
End Sub

如果您只需要列的一部分，请指定要复制的范围而不是整列：

Sub CopyPartOfColumn()
    ' copying this way does not use your clipboard
    Range("D2:D500").Copy Range("F2:F500")
End Sub

您在问题下方的评论中提到您希望结果列是没有空格的值的合并列表。您可以通过删除列或范围中的空白来快速完成此操作，而无需循环。在您复制了所需的值后运行此项。

Sub RemoveBlanks()
    Range("F2:F500").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub

Excel VBA - 循环以检查整个列范围而不是每个单元格

3 个答案: