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
-----------------------
问题（查看输出）位于验证集合列表中。我不明白为什么它会被重复为同一个。它有正确数量的validations.count，应该有，但我不知道。关注这个问题3天了。编程不是我的强项。
测试文件可以在这里获取：https://drive.google.com/file/d/1IWKKfN6zY1zjUMNcz_OGnQ3u24Qf1Ira/view?usp=drive_link
请帮忙。
我已经尝试了 for 循环、go tos 和 if 语句的所有组合。我已经尝试了很多，但我无法弄清楚。太笨了。
很抱歉转储代码块，但它本质上是一个被分解的大函数，我认为单独来说没有意义，或者也许代码从一开始就写得很糟糕，所以一切都在这里。
如果您想在工作表上找到使用的矩形范围，那么这种方法是可靠的：
'Find the bottom-right corner of the used range on `ws`
' Return Nothing if no content on sheet
Function LastCell(ws As Worksheet) As Range
Dim fR As Range, fC As Range
Set fR = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, , xlByRows, xlPrevious)
Set fC = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
If Not fR Is Nothing Then
Set fC = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
Set LastCell = ws.Cells(fR.Row, fC.Column)
End If
End Function
测试
Nothing