读取文本文件并填写下拉列表

Question

我正在编写一个读取文本文件 (test.txt) 并填写下拉列表的 Excel vba 脚本。 下拉列表包含以下项目：

苹果
梨
柠檬
石灰

文本文件有：

苹果
苹果片
大苹果
柠檬汁
柠檬
梨片

我想得到的是，当它在下拉列表中的文本文件中读取 Apple 切片时，它被设置为 Apple。当它读取 Big apple 时，下拉列表设置为 Apple。

这是我的代码

Sub CopyTXT()

    Dim myFile, textline
    Dim compare As String
    Dim sArray() As String
    Dim mywnd As Long
    Dim i As Integer
    Dim cell As Range
    Dim dbsheet As Worksheet
    Dim myArray() As Variant
    Dim myTable As ListObject
    Dim x As Long

    Set myTable = Worksheets("Sheet2").ListObjects("Table3")
    TempArray = myTable.DataBodyRange.Columns(1)
    myArray = Application.Transpose(TempArray)

    Set dbsheet = ThisWorkbook.Sheets("Sheet1")
    lr = dbsheet.Cells(Rows.Count, 1).End(xlUp).Row
    Charr = Chr$(160)
    myFile = "test.txt"

    For y = 1 To lr
        If Not dbsheet.Cells(y, 1) = Charr Then
            Close #1
             Open myFile For Input As #1
            Do Until EOF(1)
                Line Input #1, textline
                    For x = LBound(myArray) To UBound(myArray)
                    If InStr(1, textline, myArray(x), vbTextCompare) > 0 Then
                        dbsheet.Cells(y, 1).Value = textline
                        x = x + 1
                    End If
                    Next x
                y = y + 1
            Loop
        End If
    Next
        Close #1
    End Sub

Answer 1

根据我的第一条评论

如果我理解正确，您的数组 myArray 包含正确的单字 下拉列表中的值将填充到工作表中。在 在这种情况下，如果您将输入 If InStr(1, textline, myArray(x), vbTextCompare) > 0 Then 与数组中的项目匹配 - 您必须分配 从数组到单元格的值，而不是文本行：dbsheet.Cells(y, 1).Value = myArray(x)

和 OPs 澄清，我假设以下可能会有所帮助，但是评论太长并且需要格式化，因此作为答案发布：

Dim z As Long

For x = LBound(myArray) To UBound(myArray)
    ' in case there is a partial match found in line
    If InStr(1, textline, myArray(x), vbTextCompare) > 0 Then
        ' perform a word by word check of that line:
        ' put words to an array by splitting the text line with a space as delimiter
        For z = LBound(Split(textline, " ")) To UBound(Split(textline, " "))
            ' if one of words exactly matches the mask (myArray(x))
            If Split(textline, " ")(z) = myArray(x) Then
                ' then put it into a cell
                dbsheet.Cells(y, 1).Value = textline
                x = x + 1
            End If
        Next
    End If
Next x

但这不适用于Apple和Apples的比较，需要考虑一下。