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 - 循環檢查整個列範圍而不是每個單元格

回答

相關問題