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

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

代码如下

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

来源

2014-10-01 PootyToot

你能排序吗？使用公式怎么样？我的意思是，如果你想做的是简单的“IF公式”可以做到这一点。为什么选择VBA？ – L42 2014-10-01 02:27:11

还有更多的代码遍历列表，找到空白并删除它们（有效地创建一个综合列表）。你可以使用公式来做到这一点，但它是难以置信地对内存征税（该表用于有一个数组公式，但if循环做得更有效） – PootyToot 2014-10-01 02:32:06

好吧，我发布了一些东西。这在不到一秒的时间内处理你的例子。 – L42 2014-10-01 02:37:18

这里有一种方法：

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。

来源

2014-10-01 02:31:50 L42

这样做！它现在运行速度更快，我认为现在唯一扼杀时间的就是摆脱所有空白单元格的路线，如下所示。你能建议任何东西把它建立到转置范围吗？对于K = 2〜500 如果细胞（K，6）.value的= “” 那细胞（K，6）.SpecialCells（xlCellTypeBlanks）.Delete xlShiftUp 结束如果下面k个 – PootyToot 2014-10-01 02:55:48

@PootyToot你想尝试什么我在后续发布。 – L42 2014-10-01 03:03:06

尽量简单地做这第一个，看它是否有差别：

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

来源

2014-10-01 01:51:52 Enigmativity

我应该添加，代码已经将计算设置为手动，但它被设置在更早的子集中 – PootyToot 2014-10-01 01:55:18

@PootyToot - 屏幕更新如何？ – Enigmativity 2014-10-01 02:15:24

屏幕更新也设置为false，直到代码结束，我正在尝试你的变体，看看它是否可以工作 – PootyToot 2014-10-01 02:33:08

如果空格被复制，它不会对您的目标列产生任何影响，所以不要打扰检查它们。 不要循环 - 只需复制整个列。

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

来源

2014-10-01 03:31:56

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

回答

相关问题