vlookup分割值VBA

我创建了一个类似于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

Sub-Metadane（）
将ws设置为工作表
调暗aCell作为范围，rng作为范围
朦胧如长，我如长
暗myAr
将ws2设置为工作表
变暗bCell作为范围，rng2作为范围
作为字符串的Dim变量
“~~>将此更改为相关工作表
设置ws=ThisWorkbook.Sheets（“Sheet1”）
与ws
“~~>查找列A中的最后一行
Lrow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
设置rng=.Range（“A1:A”和Lrow）
Set ws2=thiswoolk.Sheets（“Sheet2”）
与ws2
“~~>查找列A中的最后一行
Lrow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
“~~>设置您的范围
设置rng2=.Range（“A1:A”和Lrow）
“~~>在您的范围内循环
对于rng2中的每个bCell
如果Len（Trim（bCell.Value））为0，则
变量=bCell.Value
对于rng中的每个aCell
“~~>如果单元格A中的值为空，则跳过该行
如果Len（Trim（aCell.Value））为0，则
“~~>检查单元格是否有”
“~~>如果有”；“则循环遍历值
如果InStr（1，aCell.Value，“；”），则
myAr=拆分（aCell.Value，“；”）
对于i=LBound（myAr）到UBound（myAr）
如果myAr=变量，则
工作表（“sheet2”）.b单元格（，2）.粘贴特殊XLPaste值
接下来我
其他的
工作表（“sheet2”）.b单元格（，2）.粘贴特殊XLPaste值
如果结束
如果结束
下一个
如果结束
下一个
以
端接头

我更改了代码，但仍然无法正常工作，我有一个结果：

---

您正在粘贴一些尚未复制的内容，您忘记用关闭一个

，并且您不能使用
bCell（，2）
，因此

试试这个：

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

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)
End With


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(i) <> variable Then
                            Else
                                'You were pasting nothing with that
                                '.bCell(, 2).PasteSpecial xlPasteValues
                                .Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value

                            End If
                        Next i
                    Else
                        'Same here
                        '.bCell(, 2).PasteSpecial xlPasteValues
                        .Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value

                    End If
                End If
            Next aCell

        End If
    Next bCell
End With

End Sub

Sub-Metadane（）
将ws设置为工作表
调暗aCell作为范围，rng作为范围
朦胧如长，我如长
Dim myAr（）作为字符串
将ws2设置为工作表
变暗bCell作为范围，rng2作为范围
作为字符串的Dim变量
“~~>将此更改为相关工作表
设置ws=ThisWorkbook.Sheets（“Sheet1”）
与ws
“~~>查找列A中的最后一行
Lrow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
设置rng=.Range（“A1:A”和Lrow）
以
Set ws2=thiswoolk.Sheets（“Sheet2”）
与ws2
“~~>查找列A中的最后一行
Lrow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
“~~>设置您的范围
设置rng2=.Range（“A1:A”和Lrow）
“~~>在您的范围内循环
对于rng2中的每个bCell
如果Len（Trim（bCell.Value））为0，则
变量=bCell.Value
对于rng中的每个aCell
“~~>如果单元格A中的值为空，则跳过该行
如果Len（Trim（aCell.Value））为0，则
“~~>检查单元格是否有”
“~~>如果有”；“则循环遍历值
如果InStr（1，aCell.Value，“；”），则
myAr=拆分（aCell.Value，“；”）
对于i=LBound（myAr）到UBound（myAr）
如果是myAr（i）变量，则
其他的
“你没有用它粘贴任何东西
'.bCell（，2）.paste特殊XLPaste值
.Cells（bCell.Row，2）=aCell.Offset（0，1）.Value
如果结束
接下来我
其他的
“这里也是
'.bCell（，2）.paste特殊XLPaste值
.Cells（bCell.Row，2）=aCell.Offset（0，1）.Value
如果结束
如果结束
下一个亚塞尔
如果结束
下一个B单元
以
端接头
试试这个

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

子测试（）
尺寸Cl作为范围，键作为变型
Dim Dic As Object:Set Dic=CreateObject（“Scripting.Dictionary”）
Dic.CompareMode=vbTextCompare
附页（“第1页”）
对于范围内的每个Cl（“A1:A”和.Cells.SpecialCells（xlCellTypeLastCell.Row）
如果Cl.值为“”，则
Dic.添加Cl.行和“|”并替换（LCase（Cl.Value），“；”，“||”）和“|”，Cl.Offset（，1）.Text
如果结束
下一个Cl
以
附页（“第2页”）
对于范围内的每个Cl（“A1:A”和.Cells.SpecialCells（xlCellTypeLastCell.Row）
对于Dic中的每个键
如果像“*|”&LCase（Cl.Value）&“|*”和Cl.Value”这样的键，那么
Cl.偏移量（，1）.值=Dic（键）
退出
如果结束
下一键
下一个Cl
以
端接头

输出结果

Sub YourVLookup()

    Dim rng As Variant, rng2 As Variant
    Dim lastRow As Long, i As Long, j As Long, k As Long
    Dim aCell As Variant, bCell As Variant
    Dim myAr() As String, variable As String

    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow)
    lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
    Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow)

    For i = LBound(rng2, 1) To UBound(rng2, 1)
        If Len(Trim(rng2(i, 1))) <> 0 Then
            variable = rng2(i, 1)
            For j = LBound(rng, 1) To UBound(rng, 1)
                If Len(Trim(rng(j, 1))) <> 0 Then
                    If InStr(1, rng(j, 1), ";") > 0 Then
                        myAr = Split(rng(j, 1))
                        For k = LBound(myAr) To UBound(myAr)
                            If myAr(k) = variable Then
                                rng2(i, 2) = myAr(k)
                            End If
                        Next k
                    ElseIf rng(j, 1) = rng2(i, 1) Then
                        rng2(i, 2) = rng(j, 2)
                    End If
                End if
            Next j
        End If
    Next i

    lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow) = rng
    lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
    ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow) = rng2

End Sub

Sub YourVLookup（）
尺寸rng作为变型，rng2作为变型
最后一行一样长，我一样长，j一样长，k一样长
Dim aCell作为变体，bCell作为变体
Dim myAr（）作为字符串，变量作为字符串
lastRow=此工作簿。工作表（“Sheet1”）。单元格（Rows.Count，1）。结束（xlUp）。行
Set rng=ThisWorkbook.Worksheets（“Sheet1”）.Range（“A1:B”和lastRow）
lastRow=此工作簿。工作表（“Sheet2”）。单元格（Rows.Count，1）。结束（xlUp）。行
设置rng2=ThisWorkbook.Worksheets（“Sheet2”）.Range（“A1:B”和lastRow）
对于i=LBound（rng2，1）到UBound（rng2，1）
如果Len（Trim（rng2（i，1）））为0，则
变量=rng2（i，1）
对于j=LBound（rng，1）到UBound（rng，1）
如果Len（Trim（rng（j，1）））为0，则
如果InStr（1，rng（j，1），“；”）大于0，则