Insert Data Validation in ever changing sheets using CountA and Offset in VBA

Question

I receive data that is similar in content, yet varies in the number and order of columns. I installed a drop down permanently in A6, copying it to each column in row 6,of the other columns, then select the appropriate header from the list. How can I amend my macro so it would either copy the DV from A6 or create identical headers where required? (determined by countA in Row 5)

This VBA solution places text where I want the dropdowns. Please tell me what I should use to replace the text "same dropdown as A6" so that it will automatically insert a dropdown with the header choices.

Private Sub CmdSubmit_Click()
    Dim i As Integer
   For i = 1 To 50


    ActiveSheet.Select
    Range("A5").Select

    If ActiveCell.Offset(0, 1).Value >= "1" Then
        ActiveCell.Offset(1, 0).Select
    Else
        Selection.End(xlToLeft).Offset(0, 1).Select
    End If
    ActiveCell.Offset(0, 1).Value = "same drop down as A6"
    ActiveCell.Offset(0, 2).Value = "same drop down as A6"
    ActiveCell.Offset(0, 3).Value = "same drop down as A6"
    ActiveCell.Offset(0, 4).Value = "Same drop down as A6"
   Next i

End Sub

This works, but it is not dynamic: Can we make it dynamic? Sub Thiscopypaste() Dim rngcopy As Range Dim i As Integer

Set rngcopy = ActiveSheet.Range("A6")

    rngcopy.Copy


Range("B5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

Range("C5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
 Range("D5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("E5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
 ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("F5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End If End Sub

hello elaine. It is hard to know exactly what you are asking. Could you please give more information with examples and perhaps a screenshot of what you want. Thx. — IAmNerd2000
Thank Nerd2000, I have attached the screenshot as a link at the very beginning of my question. I want to be able to insert dropdowns in the cells outlined in red. — Elaine
Thank you, Nerd2000. We’re almost there. A copy of the A6 dropdown is only required if cell B5, B6, etc., have values >=1. (I am sorry I caused the confusion with the example I provided showing four offsets.) I need the insertion of additional dropdowns be dynamic based on whether the counta in row 5 indicates the need for the dropdown. How can this be accomplished? Thanks! Your kind efforts are appreciated. — Elaine
Are you sure it is not cells on the 5th row that need to have values >= 1 (ex. b5, c5, d5, etc...)? — IAmNerd2000
I updated the answer. that may be what you are looking for. Remember to upvote and accept as your answer if it is what you require. Thx. — IAmNerd2000

IAmNerd2000 IAmNerd2000 · Accepted Answer · 2019-01-30T21:16:56

If the dropdown you speak of is a data validation list then you need to perform the following:

    Private Sub CmdSubmit_Click()
        Dim i As Integer
        Dim rngCopy As Range

       For i = 1 To 50

        'ActiveSheet.Select
        Set rngCopy = ActiveSheet.Range("A6")

        rngCopy.Copy

        If rngCopy.Offset(-1, i).Value >= 1 Then
            'ActiveCell.Offset(1, 0).Select
            rngCopy.Offset(0, i).PasteSpecial xlPasteAll
        Else
            Set rngCopy = rngCopy.End(xlToLeft).Offset(0, i)
        End If
        'rngCopy.Offset(0, i).PasteSpecial xlPasteAll
        'rngCopy.Offset(0, 2).PasteSpecial xlPasteAll
        'rngCopy.Offset(0, 3).PasteSpecial xlPasteAll
        'rngCopy.Offset(0, 4).PasteSpecial xlPasteAll
       Next i

       Set rngCopy = Nothing

    End Sub

Insert Data Validation in ever changing sheets using CountA and Offset in VBA

1 Answers