vlookup 拆分值 VBA

Question

我创建了像 vlookup 但具有拆分值的宏。我想从拆分值的第二个 sheet 中找到值（以分号分隔）并将描述复制并粘贴到新的 sheet.

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

但是 - 它不起作用，我不知道问题出在哪里。

我有通知"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

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

Answer 2

试试这个

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 3

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

vlookup 拆分值 VBA

vlookup split value VBA

excel

vba

split

vlookup