vlookup拆分值VBA

Question

我创建了一个像vlookup一样工作但具有拆分值的宏。我想从第二张分割值中找到值（用分号分隔），然后将描述复制并粘贴到新工作表中。

第一个循环遍历工作表2中的列表并设置变量中的值，第二个循环通过拆分值检查是否存在完全匹配，并将描述复制并粘贴到第二个工作表。

然而 - 它不起作用，我也不知道问题所在。

我有通知"type mismatch"。

我尝试使用部分文本字符串进行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

输出结果

Answer 2

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

Answer 3

您正在粘贴您尚未复制的内容，忘记关闭With，而您无法使用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