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'和一个黄色单元格，如果您希望相反您可以交换循环的顺序。

让我知道是否有什么你不明白