Excel/VBA /添加进度条
问题描述:
下面的代码在我的工作簿的不同工作表中搜索重复项。问题是它需要一点时间才能完成。如何在底部的状态栏中添加进度指示器?Excel/VBA /添加进度条
谢谢&亲切的问候。
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
答
一两件事你可以做的是加快你的代码,有几件事情我想在当前状态下改变它,
这是很慢访问范围对象和它们的值,您应该将范围加载到变量数组中并循环访问阵列
如果您发现重复项,您仍然需要检查两个阵列中的每个其他范围都浪费时间,则应该跳到下一个范围一旦你找到了重复
考虑到这一点我已经重写你这样的代码,它在完全等价和运行不到我的机器上第二:
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'和一个黄色单元格,如果您希望相反您可以交换循环的顺序。
让我知道是否有什么你不明白
谢谢你的快速回复,其工作很好。有没有办法省略范围内的空白单元格?干杯! – Ocean8
嗨海洋!我已经改变了我的代码,所以它会跳过'Screener'工作表中任何空白的单元格,这是你的意思吗? –
如果这对你有用,你可以按照接受的答案打勾,欢呼! –