vlookup拆分值VBA

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

第一个循环遍历工作表2中的列表，并将该值设置为variables，第二个循环通过拆分值检查何时完全匹配，并将描述复制并粘贴到第二个工作表。

但是 – 这是行不通的，我不知道问题是什么。

我有通知"type mismatch" 。

我尝试使用部分文本string的查找，但它也不起作用。

 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

你已经粘贴了一些你没有复制过的东西，忘记closures了，而且你不能使用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