Question

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

谢谢你＆amp;亲切的问候。

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

您可以做的一件事就是加快您的代码速度，在目前的状态下我会改变一些事情，

访问范围对象及其值非常慢，您应该将范围加载到变量数组中并循环遍历数组
如果您发现重复，您仍然会检查两个阵列中的每个其他范围，这会浪费时间，一旦找到重复

，您应该跳到下一个范围
LI>

考虑到这一点，我已经重写了这样的代码，它完全等效，并且在我的机器上运行不到一秒钟：

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

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

如果您有任何理解

，请告诉我

Excel / VBA /添加进度条

1 个答案: