在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

---

这可行，但它不是动态的：我们可以使它动态吗？ 子Thiscopypaste（） 影印范围 昏暗的整数

设置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

如果结束 结束

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