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
-----------------------
The issue (looking at the output) is on the Validations Collection list. I don't understand why it's being duplicated as the same one. It has the right amount of validations.count that there should be but idk. been staring at this problem for 3 days. Programming isn't my strong suit.
The test file can be gotten here: https://drive.google.com/file/d/1IWKKfN6zY1zjUMNcz_OGnQ3u24Qf1Ira/view?usp=drive_link
Please help.
I've tried all combinations of for loops and go tos and if statements. I've tried alot but I can't figure it out. too dumb.
Sorry to dump the code block, but it's essentially one big function broken down and I don't think would make sense solitarily, or maybe the code is just written badly from the start so here it all is.
A different approach, but this worked for me:
Option Explicit
Sub SynchronizeDataValidations()
Dim colWs As New Collection, Validations As Object
colWs.Add ThisWorkbook.Worksheets("TEST")
colWs.Add ThisWorkbook.Worksheets("TEST (2)")
Set Validations = GetValidations(colWs)
DumpValidations Validations
End Sub
Private Function GetValidations(shts As Collection) As Object
Dim dict As Object, c As Range, ws As Worksheet, sourceRange As Range, k As String, validation As Variant
Dim frm As String
Set dict = CreateObject("scripting.dictionary")
For Each ws In shts
For Each c In ws.Cells.SpecialCells(xlCellTypeAllValidation).Cells
If c.validation.Type = xlValidateList And Not IsEmpty(c.validation.Formula1) Then
frm = c.validation.Formula1
Set sourceRange = Nothing
On Error Resume Next 'ignore error if frm is not a range
Set sourceRange = Range(frm)
On Error GoTo 0 'stop ignoring errors
If sourceRange Is Nothing Then
Debug.Print "Non-range source: " & frm, c.Address(external:=True)
Else
k = sourceRange.Address(external:=True)
'new source range?
If Not dict.exists(k) Then dict.Add k, New Collection
dict(k).Add c 'add this cell to the appropriate collection
End If 'have source range
End If 'list type
Next c
Next ws
Set GetValidations = dict
End Function
Sub DumpValidations(vals As Object)
Dim k, c As Range
' Debug print the validations collection
Debug.Print "=== Validations Collection ==="
Debug.Print vals.Count & " validations in collection"
For Each k In vals
Debug.Print "-----------------------"
Debug.Print "Source: " & k
For Each c In vals(k)
Debug.Print , c.Address(external:=True)
Next c
Next k
End Sub