Excel / VBA /添加进度条

下面的代码在我的工作簿的不同页面中search重复项。 问题是需要一点时间才能完成。 如何在底部的状态栏中添加进度指示器？

谢谢你，亲切的问候。

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

你可以做的一件事是加速你的代码，在当前状态下我会改变一些东西，

• 访问范围对象和它们的值真的很慢，您应该将范围加载到variables数组中并循环访问数组

• 如果您发现重复，您仍然通过检查两个arrays中的其他范围浪费时间，一旦发现重复，您应该跳到下一个范围

考虑到这一点，我重写了你的代码，这是完全相同的，在我的机器上运行不到一秒钟：

 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 

我首先检查“完整数据”表中的重复项，这意味着如果两个表中都有重复项，那么它将默认为“报告”和黄色单元格，如果您希望相反，则可以交换循环顺序。

让我知道如果有什么你不明白的