Preserve data validation input messages when dragging

[matt767]

I want to be able to retain data validation input messages when dragging the value of one dv cell to another with a different input message. To do this I'm trying to establish a collection of input messages before any edits to the sheet are made so that when I drag a dv cell's value to another a sub is called that replaces the copied over input messages with the originals. In my sample cells A1:A3 have data validation with input messages message, message2, and message3 respectively.

In the following sub which I run before editing the sheet I establish the collection of input messages and pass it to a sub called test to be called upon a sheet change:

Sub StoreDataValidationInputMessages()
    Dim ws As Worksheet
    Dim cell As Range
    Dim dataValidationMessages As New Collection
   
    Set ws = ThisWorkbook.Worksheets("Sheet1")
   
    For Each cell In ws.Range("A1:A3")
        If Not cell.Validation Is Nothing Then
            dataValidationMessages.Add cell.Validation.InputMessage, cell.Address
        End If
    Next cell
    test dataValidationMessages
End Sub

the test sub is as follows:

Sub test(ByRef dataValidationMessages As Collection)
    Dim ac As Range
    Set ac = ActiveCell
    Dim cell As Range
    For Each cell In Range(ac, ac.End(xlUp).Offset(1, 0))
    cell.Validation.InputMessage = dataValidationMessages(cell.Address)
    Next cell
End Sub

and the ThisWorkbook sheet change sub that calls test when an edit is made is as follows:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rng As Range
Set rng = Range("A1:A50")
If Not Intersect(Target, rng) Is Nothing Then
    test (dataValidationMessages)
End If
End Sub

However when I edit the sheet in the target range a 424 object required error occurs on the 'test (dataValidationMessages)' line in the private sub saying dataValidationMessages = Empty. Also, when I run Sub StoreDataValidationInputMessages() before editing the sheet it seems to run the test sub automatically because the currently selected cell needs to have an input message. Any help would be greatly appreciated. I hate that there is no easy way to preserve data validation settings/contents when dragging one dv cell to another.

 

[matt767]

This will probably get deleted, but something which shall remain nameless gave me a functional solution, in one block of code pasted into ThisWorkbook, without needing the 'test' sub and requiring running the StoreDataValidationInputMessages sub beforehand:

Dim dataValidationMessages As New Collection
Sub StoreDataValidationInputMessages()
    Dim ws As Worksheet
    Dim cell As Range

    Set ws = ThisWorkbook.Worksheets("Sheet1")
 
    For Each cell In ws.Range("A1:A3")
        If Not cell.Validation Is Nothing Then
            dataValidationMessages.Add cell.Validation.InputMessage, cell.Address
        End If
    Next cell
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim rng As Range
    Set rng = Range("A1:A50")

    If Not Intersect(Target, rng) Is Nothing Then
        Dim cell As Range
        For Each cell In Target
            If Not cell.Validation Is Nothing Then
                cell.Validation.InputMessage = dataValidationMessages(cell.Address)
            End If
        Next cell
    End If
End Sub

I can have the store sub run automatically every time a workbook is opened or a new sheet is selected. Now I just need to find a way to avoid crashes when a cell without dv is dragged over.

 

[matt767]

I could only find a solution for the non-data validation cells which just leaves the input message blank but still copies over the rest of the validation settings.

 

[matt767]

my solution which still copied over data validation to blank cells:

Dim dataValidationMessages As New Collection
Function ISDatavalidation(rge As Range) As Boolean
    On Error Resume Next
    DVtype = rge.Validation.Type
    On Error GoTo 0
    If DVtype > 0 Then
    ISDatavalidation = True
    Else
    ISDatavalidation = False
    End If
End Function
Sub StoreDataValidationInputMessages()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rng = ws.Range("A1:A10")

    For Each cell In rng
        On Error Resume Next
        If ISDatavalidation(cell) = True Then
            dataValidationMessages.Add cell.Validation.InputMessage, cell.Address
        Else
            dataValidationMessages.Add "", cell.Address
        End If
        On Error GoTo 0
    Next cell
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim rng As Range
    Set rng = Range("A1:A50")

    If Not Intersect(Target, rng) Is Nothing Then
        Dim cell As Range
        For Each cell In Target
            If Not cell.Validation Is Nothing Then
                cell.Validation.InputMessage = dataValidationMessages(cell.Address)
            End If
        Next cell
    End If
End Sub

The problem is once the cells are dragged the data validation settings get copied, but is there a way to 'store' the blank cells along with the input messages so they can be reverted once they are copied over?

 

[matt767]

I found a solution:

Dim dataValidationMessages As New Collection
Function ISDatavalidation(rge As Range) As Boolean
    On Error Resume Next
    DVtype = rge.Validation.Type
    On Error GoTo 0
    If DVtype > 0 Then
    ISDatavalidation = True
    Else
    ISDatavalidation = False
    End If
End Function
Sub StoreDataValidationInputMessages()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rng = ws.Range("A1:A10")

    For Each cell In rng
        On Error Resume Next
        If ISDatavalidation(cell) = True Then
            dataValidationMessages.Add cell.Validation.InputMessage, cell.Address
        Else
            dataValidationMessages.Add "blank", cell.Address
        End If
        On Error GoTo 0
    Next cell
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim rng As Range
    Set rng = Range("A1:A50")

    If Not Intersect(Target, rng) Is Nothing Then
        Dim cell As Range
        For Each cell In Target
            If Not cell.Validation Is Nothing Then
                cell.Validation.InputMessage = dataValidationMessages(cell.Address)
            End If
        Next cell
        For Each cell In Target
        On Error Resume Next
            If Not cell.Validation Is Nothing Then
                If cell.Validation.InputMessage = "blank" Then
                    cell.Validation.Delete
                    cell.ClearComments
                End If
                On Error GoTo 0
            End If
        Next cell
    End If
End Sub