如何加快我的VBA腳本

我有一張7800行約2382列約一張。（19.5Million Cells）如何加快我的VBA腳本

在此之外，我有22 x列，我實際上感興趣，其中有5 x位數字散佈在其中。

本質上，如果第一列中的數字然後在其他21 x列中的任何一列中找到，我想打開相關的行，列中的單元格內部爲紅色。

我有這個工作，我相信與附加的代碼，但它需要大約3 x小時運行。

我想問一下，這是一個合理的時間（3 x小時）與電子表格的大小？

如果你期望例程更快，我將非常感謝你的指導，應該如何編寫腳本。

Sub FindMatch() 


Dim rng_1 As Range 
Dim rng_2 As Range 
Dim rng_3 As Range 
Dim rng_4 As Range 
Dim rng_5 As Range 
Dim rng_6 As Range 
Dim rng_7 As Range 
Dim rng_8 As Range 
Dim rng_9 As Range 
Dim rng_10 As Range 
Dim rng_11 As Range 
Dim rng_12 As Range 
Dim rng_13 As Range 
Dim rng_14 As Range 
Dim rng_15 As Range 
Dim rng_16 As Range 
Dim rng_17 As Range 
Dim rng_18 As Range 
Dim rng_19 As Range 
Dim rng_20 As Range 
Dim rng_21 As Range 
Dim rng_22 As Range 



Dim rngRef_1 As Range 
Dim rngRef_2 As Range 
Dim rngRef_3 As Range 
Dim rngRef_4 As Range 
Dim rngRef_5 As Range 
Dim rngRef_6 As Range 
Dim rngRef_7 As Range 
Dim rngRef_8 As Range 
Dim rngRef_9 As Range 
Dim rngRef_10 As Range 
Dim rngRef_11 As Range 
Dim rngRef_12 As Range 
Dim rngRef_13 As Range 
Dim rngRef_14 As Range 
Dim rngRef_15 As Range 
Dim rngRef_16 As Range 
Dim rngRef_17 As Range 
Dim rngRef_18 As Range 
Dim rngRef_19 As Range 
Dim rngRef_20 As Range 
Dim rngRef_21 As Range 
Dim rngRef_22 As Range 


Application.Calculation = xlManual 
Application.ScreenUpdating = False 

Set rng_1 = Worksheets("Sheet1").Range("$DQ$2:$DQ$8000") 
Set rng_2 = Worksheets("Sheet1").Range("$GW$2:$GW$8000") 
Set rng_3 = Worksheets("Sheet1").Range("$KC$2:$KC$8000") 
Set rng_4 = Worksheets("Sheet1").Range("$NI$2:$NI$8000") 
Set rng_5 = Worksheets("Sheet1").Range("$QO$2:$QO$8000") 
Set rng_6 = Worksheets("Sheet1").Range("$TU$2:$TU$8000") 
Set rng_7 = Worksheets("Sheet1").Range("$XA$2:$XA$8000") 
Set rng_8 = Worksheets("Sheet1").Range("$AAG$2:$AAG$8000") 
Set rng_9 = Worksheets("Sheet1").Range("$ADM$2:$ADM$8000") 
Set rng_10 = Worksheets("Sheet1").Range("$AGS$2:$AGS$8000") 
Set rng_11 = Worksheets("Sheet1").Range("$AJY$2:$AJY$8000") 
Set rng_12 = Worksheets("Sheet1").Range("$ANE$2:$ANE$8000") 
Set rng_13 = Worksheets("Sheet1").Range("$AQK$2:$AQK$8000") 
Set rng_14 = Worksheets("Sheet1").Range("$ATQ$2:$ATQ$8000") 
Set rng_15 = Worksheets("Sheet1").Range("$AWW$2:$AWW$8000") 
Set rng_16 = Worksheets("Sheet1").Range("$BAC$2:$BAC$8000") 
Set rng_17 = Worksheets("Sheet1").Range("$BDI$2:$BDI$8000") 
Set rng_18 = Worksheets("Sheet1").Range("$BGO$2:$BGO$8000") 
Set rng_19 = Worksheets("Sheet1").Range("$BJU$2:$BJU$8000") 
Set rng_20 = Worksheets("Sheet1").Range("$BNA$2:$BNA$8000") 
Set rng_21 = Worksheets("Sheet1").Range("$BQG$2:$BQG$8000") 
Set rng_22 = Worksheets("Sheet1").Range("$BTM$2:$BTM$8000") 







Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_2 In rng_2 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_2.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_3 In rng_3 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_3.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_4 In rng_4 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_4.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 


Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_5 In rng_5 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_5.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_6 In rng_6 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_6.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_7 In rng_7 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_7.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 




Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_8 In rng_8 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_8.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_9 In rng_9 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_9.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_10 In rng_10 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_10.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 


Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_11 In rng_11 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_11.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_12 In rng_12 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_12.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_13 In rng_13 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_13.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 

Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_14 In rng_14 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_14.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 


Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_15 In rng_15 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_15.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_16 In rng_16 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_16.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_17 In rng_17 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_17.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 




Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_18 In rng_18 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_18.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_19 In rng_19 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_19.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_20 In rng_20 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_20.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 


Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_21 In rng_21 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_21.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 
For Each rngRef_1 In rng_1 
    For Each rngRef_22 In rng_22 
    If rngRef_1.Value <> "" Then 
     If rngRef_1.Value = rngRef_22.Value Then 

     rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 

     End If 
    End If 
    Next 
Next 
Rem ----------------------------------------------------- 



Application.Calculation = xlAutomatic 
Application.ScreenUpdating = True 


End Sub

來源

2014-02-05 user3274198

你> 19M細胞和<100K號。爲什麼不先找到所有5位數的數字，然後只是將A列中的那些數字變成紅色，然後找到？ –

嗨亞歷克斯，你會怎麼做，我看不到一種方法 – user3274198

爲了讓事情你可以更快的代碼

For Each rngRef_1 In rng_1 
    For Each rngRef_2 In rng_2 
     If rngRef_1.Value <> "" Then 
      If rngRef_1.Value = rngRef_2.Value Then 
       rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 
      End If 
     End If 
    Next 
Next

改變

For Each rngRef_1 In rng_1 
    If Application.WorksheetFunction.CountIf(rng_2, rngRef_1.Value) > 0 Then _ 
    rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0) 
Next

同樣爲別人着想。這樣可以避免循環並使用CountIf公式檢查重複項。

注意：爲了使您的現有代碼更快，而不使用上述建議的方法，rngRef_1.Offset(0, -120).Interior.Color = RGB(255, 0, 0)之後添加Exit For。比賽結束後，沒有進一步檢查的重點。對其他人也是如此。

進一步優化：我花了一些時間閱讀你的代碼，我注意到了一些東西。你的代碼由283線可以減少到只有53線 :)

關鍵是在你的代碼來識別的模式。您的比較範圍從山口DQ開始直到直到BTM列各系列之間的區別是84列即

GW = 205 
NI = 373 

and so on... 

BTM = 1885

因此，所有我們現在要做的是構建一個循環的下一個範圍，而不是預先給它。而不是在一個循環中着色單元格，我們正在循環之外進行。這也將加快東西:)

新代碼（未經測試）

Option Explicit 

Sub FindMatch() 
    Dim ws As Worksheet 
    Dim rng As Range, rngRef As Range, aCell As Range, colorMyRange As Range 
    Dim nCalc As Long, i As Long 

    On Error GoTo Whoa 

    Set ws = ThisWorkbook.Sheets("Sheet1") 

    With Application 
     nCalc = .Calculation 
     .Calculation = xlManual 
     .ScreenUpdating = False 
    End With 

    With ws 
     Set rng = .Range("$DQ$2:$DQ$8000") 

     For i = 205 To 1885 Step 84 
      Set rngRef = .Range(.Cells(2, i), .Cells(8000, i)) 

      For Each aCell In rng 
       If Application.WorksheetFunction.CountIf(rngRef, aCell.Value) > 0 Then 
        If colorMyRange Is Nothing Then 
         Set colorMyRange = aCell.Offset(0, -120) 
        Else 
         Set colorMyRange = Union(colorMyRange, aCell.Offset(0, -120)) 
        End If 
       End If 

      Next 

      If Not colorMyRange Is Nothing Then 
       colorMyRange.Interior.Color = RGB(255, 0, 0) 
       Set colorMyRange = Nothing 
      End If 
     Next i 
    End With 

LetsContinue: 

    With Application 
     .Calculation = nCalc 
     .ScreenUpdating = True 
    End With 

    Exit Sub 
Whoa: 
    MsgBox Err.Description 
    Resume LetsContinue 
End Sub

來源

2014-02-05 09:21:05

謝謝Siddharth，我會很快修改代碼並試一試。 – user3274198

@ user3274198：我剛修好了一個錯字。您可能需要刷新頁面 –

也可以將您的代碼降低到現在的1/10 :) –

如何加快我的VBA腳本

回答

相關問題