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

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

苹果
梨
柠檬
石灰

文本文件包含：

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

我想得到的是，当它在下拉列表中的文本文件中读取苹果切片时，它被设置为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

---

根据我的第一个评论

---

如果我理解正确，您的数组

myArray

包含正确的一个单词 要填充到工作表中的下拉列表中的值。在里面 如果您匹配输入

if InStr（1，textline，myArray（x），
vbTextCompare）>0，然后

数组中有项-您必须分配 数组到单元格的值，而不是文本行：

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

---

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

如果我理解正确，您的数组

myArray

包含正确的单字值，如下拉列表中所示，将填充到工作表中。在这种情况下，如果您匹配输入

如果InStr（1，textline，myArray（x），vbTextCompare）>0，则
与数组中的项匹配-您必须将数组中的值分配给单元格，而不是文本行：
dbsheet.Cells（y，1）。value=myArray（x）
。感谢您的快速回复。这部分修复了现在列表中出现的zoete aardapple（汗水土豆）的问题，它与不正确的苹果相匹配。哈哈。在我分割myArray之后，它开始工作了对于x=LBound（myArray）到UBound（myArray）的arrStrings=Split（myArray（x））'