VBA用vlookup对多列数据复制

hotf4zhl

求帮忙写个VBA对多列数据用vlookup的代码。

或者帮忙写B和C列也可以，其他列的数据我可以自己修改。

里面有个成品的工作表只最后的样子。

先谢了！

我想要的其实是，sheet1变成“成品”的样子。b列和C列带着vlookup的那种。vlookup的数值是参考sheet2里面的数据。

抱歉，之前没有说清楚.

lsc900707

没有看懂根据哪列来vlookup

xiangbaoan

sheet2中E列数据6472个，去重后也就是122个
成品表中 vlookup 用精确匹配，得到的是第一条，请问结果是否靠谱?若是，才能编写语句。
就在这样补充：
Sub test() '与表中结果一致，请测试
Dim d As Object, ar(), br, tp, r&, c%, s$, y&
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet2")
    tp = .Range("e6:h" & .Cells(.Rows.Count, 5).End(xlUp).Row)
End With
For r = 1 To UBound(tp)
    If Not d.exists(tp(r, 1)) Then d(tp(r, 1)) = r
Next
With Sheets("成品")
    br = .Range("d6:d" & .Cells(.Rows.Count, 4).End(xlUp).Row)
    ReDim ar(1 To UBound(br), 1 To 4)
    For r = 1 To UBound(ar)
        s = Left(br(r, 1), 3)
        ar(r, 1) = s
        If d.exists(s) Then
            y = d(s)
            For c = 2 To 4 'UBound(ar, 2)
                ar(r, c) = tp(y, c)
            Next
        End If
    Next
    .[e6].Resize(UBound(ar), 4) = ar
End With
d.RemoveAll
With Sheets("sheet2")
    tp = .Range("k6:m" & .Cells(.Rows.Count, 11).End(xlUp).Row)
End With
For r = 1 To UBound(tp)
    If Not d.exists(tp(r, 1)) Then d(tp(r, 1)) = r
Next
With Sheets("成品")
    br = .Range("k6:k" & .Cells(.Rows.Count, 11).End(xlUp).Row)
    ReDim ar(1 To UBound(br), 1 To 2)
    For r = 1 To UBound(ar)
        s = br(r, 1)
        If d.exists(s) Then
            y = d(s)
            For c = 2 To 3
                ar(r, c - 1) = tp(y, c)
            Next
        End If
    Next
    .[l6].Resize(UBound(ar), 2) = ar
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub

hotf4zhl

xiangbaoan 发表于 2018-9-16 17:06
sheet2中E列数据6472个，去重后也就是122个
成品表中 vlookup 用精确匹配，得到的是第一条，请问结果是否 ...

朋友多谢你的多次帮忙。可能是我中文的表达的水平太差了。

我想要的其实是，sheet1变成“成品”的样子。b列和C列带着vlookup的那种。vlookup的数值是参考sheet2里面的数据。

数据方面确实不准确（用了randombetween的公式），但是vlookup可以正常运行就可以。

最后还是很感激你所写的代码和付出的精力与时间！

xiangbaoan

hotf4zhl 发表于 2018-9-16 19:29
朋友多谢你的多次帮忙。可能是我中文的表达的水平太差了。

我想要的其实是，sheet1变成“成品”的样子 ...

Sub test() '这样啊，请测试
Dim d As Object, ar(), br, tp, r&, c%, s$, y&
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet2")
    tp = .Range("a6:c" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For r = 1 To UBound(tp)
    If Not d.exists(tp(r, 1)) Then d(tp(r, 1)) = r
Next
With Sheets("sheet1")
    br = .Range("a6:a" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    ReDim ar(1 To UBound(br), 1 To 2)
    For r = 1 To UBound(ar)
        s = br(r, 1)
        If d.exists(s) Then
            y = d(s)
            For c = 2 To 3
                ar(r, c - 1) = tp(y, c)
            Next
        End If
    Next
    .[b6].Resize(UBound(ar), 2) = ar
End With
d.RemoveAll
With Sheets("sheet2")
    tp = .Range("e6:h" & .Cells(.Rows.Count, 5).End(xlUp).Row)
End With
For r = 1 To UBound(tp)
    If Not d.exists(tp(r, 1)) Then d(tp(r, 1)) = r
Next
With Sheets("sheet1")
    br = .Range("d6:d" & .Cells(.Rows.Count, 4).End(xlUp).Row)
    ReDim ar(1 To UBound(br), 1 To 4)
    For r = 1 To UBound(ar)
        s = Left(br(r, 1), 3)
        ar(r, 1) = s
        If d.exists(s) Then
            y = d(s)
            For c = 2 To 4
                ar(r, c) = tp(y, c)
            Next
        End If
    Next
    .[e6].Resize(UBound(ar), 4) = ar
End With
d.RemoveAll
With Sheets("sheet2")
    tp = .Range("k6:m" & .Cells(.Rows.Count, 11).End(xlUp).Row)
End With
For r = 1 To UBound(tp)
    If Not d.exists(tp(r, 1)) Then d(tp(r, 1)) = r
Next
With Sheets("sheet1")
    br = .Range("k6:k" & .Cells(.Rows.Count, 11).End(xlUp).Row)
    ReDim ar(1 To UBound(br), 1 To 2)
    For r = 1 To UBound(ar)
        s = br(r, 1)
        If d.exists(s) Then
            y = d(s)
            For c = 2 To 3
                ar(r, c - 1) = tp(y, c)
            Next
        End If
    Next
    .[l6].Resize(UBound(ar), 2) = ar
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub