Excel VBA-循環檢查整個列范圍，而不是每個單元格

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