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

我写了一个脚本，它检查列范围4（D列）中的非空值的单元格范围，如果它find非空值，则复制该值并将其粘贴到列范围6（列F ）。 该脚本运行，但速度非常慢，脚本需要5分钟来处理并完成其运行。 有没有什么办法来改进这个脚本，以便它可以在复制和粘贴值之前预先检查范围？ 看来，复制/粘贴function正在放慢速度。

下面的代码

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