vlookup拆分值VBA答案

【问题标题】：vlookup split value VBAvlookup拆分值VBA
【发布时间】：2015-07-29 16:16:55
【问题描述】：

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

我更改了我的代码，但它仍然不能正常工作，我有一个结果：

【问题讨论】：

If myAr = variable Then 你应该为这个声明添加End If。
谢谢。这很有帮助，但我仍然有问题。现在“运行时错误'13'。类型不匹配”
您正在将字符串与数组进行比较。 myAr = variable。我相信这是你的错误？您需要将其更改为myAr(i) = variable。

标签： vba excel split vlookup

【解决方案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

输出结果

【讨论】：

@user3114375 thnks，还添加了 lcase 以消除区分大小写，因为 "A" 不等于 "a"
我的真实数据出现错误“无效的模式字符串”。可能是与特殊字符有关的问题：。 ()、“”。我更改了我的代码：'If Key Like "[[]*" & LCase(Cl.Value) & "*[]]" And Cl.Value "" Then' 你认为它是正确的吗？
@user3114375 不，您在msdn.microsoft.com/en-us/library/38645c8s(v=vs.90).aspx 中描述的“无效模式字符串”的问题，请参阅我更新的帖子，"[" 替换为"|"，现在代码必须运行良好跨度>

【解决方案2】：

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

【讨论】：

我有同样的错误：类型不匹配。可能是变量有问题。
在哪一行？行和描述总是出错
If myAr(i) <> variable Then
好吧，只是应该得到split 结果的数组没有很好地声明。查看编辑：Dim myAr() as String
感谢您的帮助。它现在可以工作但不能正常工作。它只返回值 a 的最后描述。

【解决方案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

【讨论】：