vlookup拆分值VBA

Question

I have created macro that works like a vlookup but has split values. I would like to find value from second sheet of split values (separated by semicolon ) and copy and paste the description to new sheet.

The first loop goes through the list in sheet 2 and sets the value in a variable, the second loop through split values checks when there is exact match and the description is copied and pasted to the second sheet.

However - it doesn't work and I don't know what the problem is.

I have notification "type mismatch" .

I tried vlookup with part text string but it doesn't work either.

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

I changed my code but it is still not work properly, I have a result:

Answer 1

try this

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

Output Result

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

You were pasting something that you don't have copied already, you forgot to close a With , and you can't use bCell(,2) , so

Try this :

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