vba - vlookup分割值VBA

Question

我创建了一个类似于 vlookup 的宏，但具有拆分值。我想从第二张分割值(用分号分隔)中查找值，并将描述复制并粘贴到新表中。

第一个循环遍历工作表 2 中的列表并在变量中设置值，第二个循环遍历拆分值检查何时存在完全匹配，并将说明复制并粘贴到第二个工作表。

但是 - 它不起作用，我不知道问题是什么。

我收到通知“类型不匹配”。

我尝试使用部分文本字符串进行 vlookup，但它也不起作用。

Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr

Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String

'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
    '~~> Find the last row in Col A
    Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set rng = .Range("A1:A" & Lrow)

Set ws2 = ThisWorkbook.Sheets("Sheet2")
 With ws2
    '~~> Find the last row in Col A
    Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    '~~> Set your range
    Set rng2 = .Range("A1:A" & Lrow)
    '~~> Loop trhough your range
    For Each bCell In rng2
         If Len(Trim(bCell.Value)) <> 0 Then
         variable = bCell.Value

        For Each aCell In rng
            '~~> Skip the row if value in cell A is blank
            If Len(Trim(aCell.Value)) <> 0 Then
                '~~> Check if the cell has ";"
                '~~> If it has ";" then loop through values
                If InStr(1, aCell.Value, ";") Then
                    myAr = Split(aCell.Value, ";")

                    For i = LBound(myAr) To UBound(myAr)
                        If myAr = variable Then
                        Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
                    Next i

                Else
                    Worksheets("sheet2").bCell(, 2).PasteSpecial     xlPasteValues
                End If
            End If
        Next

        End If
    Next
End With
End Sub

我更改了代码，但仍然无法正常工作，我得到了结果:

Answer 1

试试这个

Sub test()
    Dim Cl As Range, Key As Variant
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    With Sheets("Sheet1")
        For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
            If Cl.Value <> "" Then
                Dic.Add Cl.Row & "|" & Replace(LCase(Cl.Value), ";", "||") & "|", Cl.Offset(, 1).Text
            End If
        Next Cl
    End With
    With Sheets("Sheet2")
        For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
            For Each Key In Dic
                If Key Like "*|" & LCase(Cl.Value) & "|*" And Cl.Value <> "" Then
                    Cl.Offset(, 1).Value = Dic(Key)
                    Exit For
                End If
            Next Key
        Next Cl
    End With
End Sub

输出结果