以编程方式将下拉列表添加到特定单元格

Question

我想知道如何使用VBA以编程方式将下拉列表添加到Excel工作表的特定单元格中，我希望能够向单元格（i，j）添加下拉列表，例如定义列表的元素。

Answer 1

以编程方式执行此操作：

With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="Value1;Value2;Value3"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With

其中Formula1的列表中的值由;分隔。

更好的方式（动态命名范围）

如果您想要在下拉列表中填充动态记录列表，请使用以下公式定义命名范围：

=OFFSET(Sheet1!$A$1;1;0;COUNTA(Sheet1!$A:$A)-1)

..假设您的数据位于Sheet1，第一行有标题：

A1  Header
A2  Value1
A2  Value2
A3  Value3

Answer 2

我终于能够破解它了！

Sub MyVlookUp()
    Const SpecialCharacters As String = " ,-,."
    Dim Str As String
    Dim newStr As String
    Dim c As Range
    Dim SrchRng As Range
    Dim SRng As Range
    Dim char As Variant
    Dim newSrchRng As Range
    Dim i As Long

    Sheets("VlookUp").Select
    Range("B7:GZ8000").Select
    Selection.ClearContents


    For i = 7 To ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

    Str = Worksheets("VlookUp").Cells(i, "A").Value
    newStr = Left(Str, 15)
    For Each char In Split(SpecialCharacters, ",")
    newStr = Replace(newStr, char, "")
    Next

    Worksheets("data").Activate
    Set SRng = ActiveSheet.Range("B1", ActiveSheet.Range("B65536").End(xlUp))
    SRng.Copy Destination:=Range("E1:E7001")
    Set SrchRng = Range("E1:E7001")
    For Each newSrchRng In SrchRng.Cells
    For Each char In Split(SpecialCharacters, ",")
    newSrchRng.Value = Replace(newSrchRng.Value, char, "")
    Next
    Next

    Set c = SrchRng.Find(newStr, LookIn:=xlValues, LookAt:=xlPart)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            Range(Cells(c.Row, 2), Cells(c.Row, 3)).Copy
            With Worksheets("VlookUp")
            .Cells(i, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial
            End With

            Set c = SrchRng.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If


    Next i
    Worksheets("VlookUp").Activate

     SrchRng.Clear
End Sub