表2工作簿从表1工作簿提取内容

lsc900707

苏阳湖wzy 发表于 2017-5-26 21:07
老师，请见附件2

简单的问题，稍后修改给你>>>>>>>>

lsc900707

苏阳湖wzy 发表于 2017-5-26 21:07
老师，请见附件2

Sub lqt()
    Set wb = GetObject(ThisWorkbook.Path & "\" & "表1.xls")
    Set d = CreateObject("scripting.dictionary")
    With Workbooks("表1.xls")
        arr = .Sheets(1).UsedRange
        For i = 2 To UBound(arr)
            d(arr(i, 4)) = Array(arr(i, 2), arr(i, 5), arr(i, 13), arr(i, 14), arr(i, 11))
        Next
    End With
    arr = [a2].CurrentRegion
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            s = d(arr(i, 1))
            For j = 0 To UBound(s)
                arr(i, j + 2) = s(j)
            Next
       End If
    Next
    [a2].Resize(UBound(arr), 6) = arr
    Set wb = Nothing
    Set d = Nothing
End Sub

lsc900707

苏阳湖wzy 发表于 2017-5-26 21:07
老师，请见附件2

修改的代码又需要审核>>>>>>>>>

苏阳湖wzy

非常感谢lsc900707老师的热情帮助，我对您的代码进行了简要学习，收获满满，再次感谢。今晚再献鲜花!

苏阳湖wzy

lsc900707老师，是否有空？请再看看附件三，同意的问题，谢谢！

lsc900707

苏阳湖wzy 发表于 2017-5-27 15:55
lsc900707老师，是否有空？请再看看附件三，同意的问题，谢谢！

同样表1引用表2的数据吗？

苏阳湖wzy

lsc900707老师，是的！

lsc900707

苏阳湖wzy 发表于 2017-5-27 16:16
lsc900707老师，是的！

Sub lqt()
    Set wb = GetObject(ThisWorkbook.Path & "\" & "表二.xls")
    Set d = CreateObject("scripting.dictionary")
    With wb.Sheets(1)
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr)
            d(arr(i, 1)) = arr(i, 2)
        Next
        wb.Close False
    End With
    arr = [l2].CurrentRegion
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then Cells(i + 1, 15) = d(arr(i, 1))
    Next
    Set wb = Nothing
    Set d = Nothing
End Sub

苏阳湖wzy

谢谢lsc900707老师，我来认真消化消化！

苏阳湖wzy

谢谢lsc900707老师，我表一工作簿的A2：k107也有数据的，运用您的代码就运行不成功，请您再指导一下！