Excel VBA循环异常：Validations集合重复问题求助

我编写了Excel VBA脚本用于同步工作表中的数据验证规则，但运行后发现Validations集合出现重复项：集合计数显示为2，但两个条目内容完全一致。

我的VBA脚本代码 #

Sub SynchronizeDataValidations()
    
    Dim targetSheets As Variant
    Set targetSheets = ThisWorkbook.Worksheets("TEST")
    
    Dim sheets As Collection
    Set sheets = GetCurrentSheets(targetSheets)

    Dim searchRanges As Collection
    Set searchRanges = GetSearchRanges(sheets)
    
    Dim Validations As Collection
    Set Validations = GetValidations(searchRanges)

End Sub

Private Function GetCurrentSheets(Optional targetSheets As Variant) As Collection
    Dim sheets As New Collection ' Collection to store worksheet objects
    Dim sheet As Worksheet

    ' Check if targetSheets is provided
    If IsMissing(targetSheets) Then
        ' Process all sheets in the workbook
        For Each sheet In ThisWorkbook.Worksheets
            sheets.Add sheet ' Add the worksheet object itself
        Next sheet
    ElseIf TypeName(targetSheets) = "Worksheet" Then
        ' Process a single specified worksheet
        sheets.Add targetSheets ' Add the single worksheet object
    Else
        ' Assume targetSheets is a collection or array of worksheets
        For Each sheet In targetSheets
            sheets.Add sheet ' Add each worksheet object from the collection/array
        Next sheet
    End If
    
    Debug.Print "Got Sheets"

Set GetCurrentSheets = sheets

End Function

Private Function GetSearchRanges(sheets As Collection) As Collection
    
    Dim searchRanges As New Collection
    
    ' Iterate through the collected sheet objects
    For Each sheet In sheets
    
        ' Find the last used cell in the sheet
        Dim lastCell As Range
        Set lastCell = sheet.UsedRange.SpecialCells(xlCellTypeLastCell)
    
        ' Skip the sheet if no cell with content was found
        If lastCell Is Nothing Then
            Debug.Print "Skipping sheet '" & sheet.Name & "' - no data found"
            GoTo NextSheet
        End If
    
        ' Define the range to iterate over based on the last used cell
        Dim rng As Range
        Set rng = sheet.Range("A1:" & lastCell.Address)
        Debug.Print "Search Range:" & rng.Address(External:=True)
    
        ' Add the array to the searchRanges collection
        searchRanges.Add rng
        
NextSheet:
    Next sheet
    Debug.Print "Got SearchRanges"

Set GetSearchRanges = searchRanges

End Function

Private Function GetValidations(searchRanges As Collection) As Collection
 ' Create a collection to store validation data
    Dim Validations As New Collection

    For Each searchRange In searchRanges
    
        Dim cell As Range
        
        For Each cell In searchRange
            If HasValidation(cell) Then
                If cell.validation.Type = xlValidateList And Not IsEmpty(cell.validation.Formula1) Then
                
                    Debug.Print "Checking: " & cell.Parent.Name & cell.Address
                    Dim sourceRange As Range
                    Set sourceRange = Range(cell.validation.Formula1)
                    
                    If Not sourceRange Is Nothing Then
                        Debug.Print "Source Found for " & sourceRange.Address(External:=True) & "  and it's " & cell.validation.Formula1
                        
                        Dim validation As Variant
                        Dim foundMatch As Boolean  ' Flag to track if a match is found
                        
                        ' Iterate through existing validations
                        For Each validation In Validations
                            ' Compare sheet-level addresses, ignoring workbook qualifier
                            If validation(1).Address(External:=False) = sourceRange.Address(External:=False) Then
                                Debug.Print "validation exists in validations"
                                ' If it exists, add the new applied range to its collection
                                validation(2).Add cell
                                Debug.Print cell.Parent.Name & "!" & cell.Address & " was added"
                                foundMatch = True
                                GoTo NextCell ' Jump to the next cell if a match is found
                            End If
                        Next validation
                        
                        ' If no match was found, add a new validation
                        If Not foundMatch Then
                            Debug.Print "no validation exists"
                        
                            ' Create a new collection to store applied ranges for this validation
                            Dim appliedRanges As New Collection
                            appliedRanges.Add cell
                        
                            ' Create a new validation data collection
                            Dim validationData As New Collection
                            validationData.Add sourceRange
                            validationData.Add appliedRanges
                        
                            ' Add the new validation to the validations collection
                            Validations.Add validationData
                            Debug.Print "Added new Validation"
                        End If
                        
NextCell:
                        ' Continue to the next cell in the outer loop
                    End If
                    
                End If
            End If
        Next cell
    Next searchRange

    ' Debug print the validations collection
    Debug.Print "=== Validations Collection ==="
    Debug.Print Validations.Count & " validations in collection"
    For Each validation In Validations
    
        Set sourceRange = validation(1)
        Set appliedRanges = validation(2)
    
        Debug.Print "Source Range: " & sourceRange.Address(External:=True) ' Include sheet name
        Debug.Print "Applied Ranges:"
        For Each appliedRange In appliedRanges
            Debug.Print "  - " & appliedRange.Address(External:=True)
        Next appliedRange
        Debug.Print "-----------------------"
    Next validation
    
Set GetValidations = Validations

End Function

Function HasValidation(ByRef cellAddress As Range) As Boolean
    Dim t As Variant
    t = Null

    On Error Resume Next
    t = cellAddress.validation.Type
    On Error GoTo 0

    HasValidation = Not IsNull(t)
End Function

调试输出结果 #

List Created
New Data Placed
Got Sheets
Got Sheets
Search Range:[Validations.xlsm]TEST!$A$1:$B$5
Got SearchRanges
Checking: TEST$A$1
Source Found for [Validations.xlsm]SETUP!$B$1:$B$6  and it's =SETUP!$B$1:$B$6
no validation exists
Added new Validation
Checking: TEST$B$1
Source Found for [Validations.xlsm]SETUP!$A$1:$A$2  and it's =SETUP!$A$1:$A$2
no validation exists
Added new Validation
Checking: TEST$A$2
Source Found for [Validations.xlsm]SETUP!$B$1:$B$6  and it's =SETUP!$B$1:$B$6
validation exists in validations
TEST!$A$2 was added
Checking: TEST$B$2
Source Found for [Validations.xlsm]SETUP!$A$1:$A$2  and it's =SETUP!$A$1:$A$2
Checking: TEST$A$3
Source Found for [Validations.xlsm]SETUP!$B$1:$B$6  and it's =SETUP!$B$1:$B$6
validation exists in validations
TEST!$A$3 was added
Checking: TEST$B$3
Source Found for [Validations.xlsm]SETUP!$A$1:$A$2  and it's =SETUP!$A$1:$A$2
Checking: TEST$A$4
Source Found for [Validations.xlsm]SETUP!$B$1:$B$6  and it's =SETUP!$B$1:$B$6
validation exists in validations
TEST!$A$4 was added
Checking: TEST$B$4
Source Found for [Validations.xlsm]SETUP!$A$1:$A$2  and it's =SETUP!$A$1:$A$2
Checking: TEST$A$5
Source Found for [Validations.xlsm]SETUP!$A$1:$A$2  and it's =SETUP!$A$1:$A$2
Checking: TEST$B$5
Source Found for [Validations.xlsm]SETUP!$A$1:$A$2  and it's =SETUP!$A$1:$A$2
=== Validations Collection ===
2 validations in collection
Source Range: [Validations.xlsm]SETUP!$B$1:$B$6
Applied Ranges:
  - [Validations.xlsm]TEST!$A$1
  - [Validations.xlsm]TEST!$B$1
  - [Validations.xlsm]TEST!$A$2
  - [Validations.xlsm]TEST!$A$3
  - [Validations.xlsm]TEST!$A$4
-----------------------
Source Range: [Validations.xlsm]SETUP!$B$1:$B$6
Applied Ranges:
  - [Validations.xlsm]TEST!$A$1
  - [Validations.xlsm]TEST!$B$1
  - [Validations.xlsm]TEST!$A$2
  - [Validations.xlsm]TEST!$A$3
  - [Validations.xlsm]TEST!$A$4
-----------------------

已尝试调整循环、GoTo语句和条件判断，但始终无法解决该问题，恳请帮忙排查原因。

内容的提问来源于stack exchange，提问作者JesseRigon