Excel/VBA /添加進度條

Question

下面的代碼在我的工作簿的不同工作表中搜索重複項。問題是它需要一點時間才能完成。如何在底部的狀態欄中添加進度指示器？

謝謝&親切的問候。

Sub dup() 
    Dim cell As Range 
    Dim cella As Range 
    Dim rng As Range 
    Dim srng As Range 
    Dim rng2 As Range 
    Dim SheetName As Variant 

    Application.ScreenUpdating = False 
    Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone 

    Columns("B:B").Select 
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 

    Set srng = Sheets("Screener").Range("A7:A2000") 
    Set rng = Sheets("Rejected").Range("A7:A2000") 
    Set rng2 = Sheets("Full Data").Range("A7:A2000") 

    For Each cell In rng 
     For Each cella In srng 
      If cella = cell Then 
       cella.Interior.ColorIndex = 4 
       cella.Offset(, 1) = "Rejected" 
      End If 
     Next cella 
    Next cell 

    For Each cell In rng2 
     For Each cella In srng 
      If cella = cell Then 
       cella.Interior.ColorIndex = 5.5 
       cella.Offset(, 1) = "Reported" 
      End If 
     Next cella 
    Next cell 

    Application.ScreenUpdating = True 

End Sub 

Answer 1

一兩件事你可以做的是加快你的代碼，有幾件事情我想在當前狀態下改變它，

• 這是很慢訪問範圍對象和它們的值，您應該將範圍加載到變量數組中並循環訪問陣列

• 如果您發現重複項，您仍然需要檢查兩個陣列中的每個其他範圍都浪費時間，則應該跳到下一個範圍一旦你找到了重複

考慮到這一點我已經重寫你這樣的代碼，它在完全等價和運行不到我的機器上第二：

Sub dup() 
    Dim i As Integer, j As Integer 
    Dim RejectVals As Variant 
    Dim ScreenVals As Variant 
    Dim FullDataVals As Variant 
    Dim SheetName As Variant 
    Dim output() As String 

    'Push column on 'Screener' sheet to the right to make space for new output 
    Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone 
    Worksheets("Screener").Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 

    'Pull the values from your 3 ranges into arrays to avoid costly cycling through ranges 
    ScreenVals = Application.Transpose(Sheets("Screener").Range("A7:A2000").Value) 
    RejectVals = Application.Transpose(Sheets("Rejected").Range("A7:A2000").Value) 
    FullDataVals = Application.Transpose(Sheets("Full Data").Range("A7:A2000").Value) 

    'Resize output column to be same size as column we're screening because 
    'we're going to place it in the column adjacent 
    ReDim output(LBound(ScreenVals) To UBound(ScreenVals)) 

    'Cycle through each value in the array we're screening 
    For i = LBound(ScreenVals) To UBound(ScreenVals) 
     'Skip without checking if the cell is blank 
     If ScreenVals(i) = vbNullString Then GoTo rejected 

     'Cycle through each value in the 'FullData' array 
     For j = LBound(FullDataVals) To UBound(FullDataVals) 
      'If it's a duplicate then 
      If ScreenVals(i) = FullDataVals(j) Then 
       'Set the relevant value in the output array to 'Reported' 
       output(i) = "Reported" 

       'Colour the cell on the 'screener' page 
       Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 5.5 

       'Skip checking more values 
       GoTo rejected 
      End If 
     Next j 

     'Next cycle through all the 'Rejected' values 
     For j = LBound(RejectVals) To UBound(RejectVals) 
      'If it's a duplicate then 
      If ScreenVals(i) = RejectVals(j) Then 
       'Set the relevant value in the output array to 'Rejected' 
       output(i) = "Rejected" 

       'Colour the cell 
       Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 4 

       'Skip checking any more values 
       GoTo rejected 
      End If 
     Next j 
rejected: 
    Next i 

    'Pop the output array in the column next to the screened range 
    Worksheets("Screener").Range("B7:B2000") = Application.Transpose(output) 
End Sub 

我爲您在「完整數據副本'表單第一個，這意味着如果兩個表中都有重複，那麼它將默認爲'Reported'和一個黃色單元格，如果您希望相反您可以交換循環的順序。

讓我知道是否有什麼你不明白