[已解决]根据相同值查找并进行复制

c888

根据相同值查找并进行复制（原函数效果）

l3xdlHhk.rar (5.1 KB, 下载次数: 7)

2010-12-11 15:57 上传

点击文件名下载附件
根据相同值查找并进行复制

最佳答案

月排行榜 / 总排行榜

liuguansky

2010-12-11 17:27

Sub justtest()
    Dim arr, dic, i&, arrt()
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet2.Cells(1, 3).CurrentRegion.Value
    For i = 2 To UBound(arr, 1)
        dic.Add arr(i, 1), i
    Next
    arr = [d80:aa80]
    With Sheet2.Cells(dic([c80].Value), 4).Resize(1, UBound(arr, 2))
        .ClearContents
        .Value = arr
    End With
    Set dic = Nothing
End Sub

5S9o7Oo0.rar (10.53 KB, 下载次数: 46)

2010-12-11 17:27 上传

点击文件名下载附件
根据相同值查找并进行复制

选择后输入记录了，点下按钮就可以在11表中更新或者增加记录了。

跳转到最佳答案楼层

那么的帅

rXAjNbmD.rar (9.28 KB, 下载次数: 11)

2010-12-11 17:17 上传

点击文件名下载附件
根据相同值查找并进行复制

fjmxwrs

2drUntNn.rar (10.4 KB, 下载次数: 3)

2010-12-11 17:17 上传

点击文件名下载附件
根据相同值查找并进行复制

liuguansky

Sub justtest()
    Dim arr, dic, i&, arrt()
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet2.Cells(1, 3).CurrentRegion.Value
    For i = 2 To UBound(arr, 1)
        dic.Add arr(i, 1), i
    Next
    arr = [d80:aa80]
    With Sheet2.Cells(dic([c80].Value), 4).Resize(1, UBound(arr, 2))
        .ClearContents
        .Value = arr
    End With
    Set dic = Nothing
End Sub

5S9o7Oo0.rar (10.53 KB, 下载次数: 46)

2010-12-11 17:27 上传

点击文件名下载附件
根据相同值查找并进行复制

选择后输入记录了，点下按钮就可以在11表中更新或者增加记录了。