Question

我希望我能挑选一些你的大脑来帮助优化我的代码。我创建了一个宏，要求用户选择一列，在该列中查找重复值，并在找到任何重复项时将字体更改为红色。它可靠而准确地运行，但使用的工作表可能包含50,000多行和30列，并且运行时间非常令人烦恼。我想知道是否有更好的方法。

我在开发过程中遇到的问题是，大多数用户都会过滤工作表以查看相关数据，如果工作表已过滤，我只想查看可见行。我在过去使用COUNTIF编写了一个类似的宏，这个宏更简单，但是当我添加可见行的唯一要求时遇到了问题。

它的工作原理是从输入框中选择所选列并将该列中的所有可见单元格值加载到数组（visibleArray）中。然后它通过复杂的嵌套循环运行，逐行查找并在visibleArray中查找该值。如果找到它，它会启动一个计数器（rollingCounter）并继续通过该数组。如果再次找到它，则行字体变为红色，将值添加到数组（dupArray），从循环中踢出，然后移动到下一行。

dupArray和dupCount用于宏末尾的一些统计信息。有一个函数（UniqueItems）在dupArray上运行，以计算我没有包含的唯一值。较长的执行时间主要发生在visibleArray加载期间，然后是嵌套循环重复搜索。

有什么简单的东西我可能会忽略吗？我感谢任何帮助。

谢谢！

Sub CheckDuplicates()

Dim input_rng, visible_rng As Range
Dim visRangeAddress As String
Dim visibleArray() As String, dupArray() As String
Dim uniqueDups As Integer
Dim num_rows, i, rangeCol, visibleCounter As Integer
Dim dupCount As Long
Dim rollingCounter, j As Integer

On Error Resume Next

Set input_rng = Application.InputBox("Choose column for duplicate search by selecting any cell in that column" & vbCrLf & "NOTE: Only filtered rows will be searched", "Select Column", Type:=8)

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

rangeCol = input_rng.Column

num_rows = Cells(Rows.Count, rangeCol).End(xlUp).row

ReDim dupArray(num_rows - 1) As String
ReDim visibleArray(num_rows - 1) As String

i = 2  'start looking in 2nd row, assuming 1st row contains header with filter designators

'Load visibleArray with visible cells in selected column
Do Until i = num_rows + 1
    If Rows(i).EntireRow.Hidden = False Then
        visibleArray(visibleCounter) = Cells(i, rangeCol).Value
        visibleCounter = visibleCounter + 1
    End If
    DoEvents
    i = i + 1
    Application.StatusBar = "LOADING ARRAY " & i & " of " & num_rows
Loop


'Loop through visible cells and look for duplicates
i = 2 'Reset i counter that cycles through visible rows

Do Until i = num_rows + 1
    If Rows(i).EntireRow.Hidden = False Then 'check for filered row
        Do Until j = visibleCounter 'j is temporary counter to run through the visibleArray
            If Cells(i, rangeCol).Value = visibleArray(j) Then 'check if cell is in visibleArray
                rollingCounter = rollingCounter + 1 'cell is in visibleArray, increment counter
                If rollingCounter > 1 Then '>1 indicates more than one occurrence in visibleArray
                    With Cells(i, rangeCol).Font 'change color
                        .ColorIndex = 3
                    End With
                    dupArray(dupCount) = Cells(i, rangeCol).Value 'load cell value to dupArray which only contains duplicates (not unique)
                    dupCount = dupCount + 1 'increment total number of duplicates
                    GoTo 10 'kick out of loop, once the cell is colored red, no reason to continue looking for more
                End If
            End If
        j = j + 1 'increment j counter to look for next value in visibleArray
        Loop
10      j = 0 'reset j and rollingCounter variables for next row (i)
        rollingCounter = 0
    End If
    Application.StatusBar = "CHECKING DUPLICATES " & i & " of " & num_rows
    i = i + 1
    DoEvents
Loop

If dupCount > 0 Then
    ReDim Preserve dupArray(dupCount - 1) 'resize dupArray (-1 since array starts at 0)
    uniqueDups = UniqueItems(dupArray, True) 'look for unique number of dups
Else
    uniqueDups = 0
End If

Application.StatusBar = ""

MsgBox "Found " & uniqueDups & " unique duplicate values with a total of " & dupCount & " occurrences."

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

寻找优化VBA Excel宏的建议，以便在过滤的工作表

0 个答案: