使用 VBA 中的 CountA 和 Offset 在不断变化的工作表中插入数据验证

Question

我收到的数据内容相似，但列的数量和顺序各不相同。我在 A6 中永久安装了一个下拉菜单，将其复制到其他列的第 6 行中的每一列，然后从列表中选择适当的标题。如何修改我的宏，以便它可以从 A6 复制 DV 或在需要时创建相同的标题？ （由第 5 行中的 countA 确定）

此 VBA 解决方案将文本放置在我想要下拉列表的位置。请告诉我应该用什么来替换文本“与 A6 相同的下拉菜单”，以便它会自动插入带有标题选项的下拉菜单。

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

---

这可行，但它不是动态的：我们可以让它动态吗？

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

Answer 1

如果您所说的下拉列表是数据验证列表，那么您需要执行以下操作：

    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