怎么用VBA实现跨工作簿匹配

wuxuezj

怎么用VBA实现跨工作簿匹配

Eva1015

两个循环和一个if判断语录就可以实现。
思路可以这样，大循环是要填充的行数，里面的循环是根据编码一个在数据1表找，找到就将对应的值填充，并退出里面的循环。再下一个。

于箱长

平时数据量很大，用vlookup更会导致文件比较大，运算比较慢，是不

于箱长

http://club.excelhome.net/thread-1529806-1-1.html参考一下，我之前发过的这个帖子，希望能帮到你

笨鸟飞不高

Sub AwTest()
    Dim i%, j%, kStr$, ws As Worksheet, wb As Workbook, arr, d As Object
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\1.xlsx")
    Set ws = wb.Sheets(1)
    arr = ws.[a1].CurrentRegion
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 8)
    Next
    wb.Close False
    [a1].CurrentRegion.Offset(1, 6) = ""
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 6)) Then
            kStr = d(arr(i, 6))
            For j = 0 To 3
                arr(i, j + 7) = Split(kStr, "|")(j)
            Next
        End If
    Next
    [a1].CurrentRegion = arr
    Application.ScreenUpdating = True
End Sub

笨鸟飞不高

跨工作簿-匹配.zip (24.93 KB, 下载次数: 102)

2020-8-11 14:19 上传

点击文件名下载附件

opel-wong

字典匹配，代码如下，
供参考：

opel-wong

代码如下，供参考：

1. Sub 跨薄匹配()
   
2.     Dim arr, i As Long, wb As Workbook, mFile As String, j As Long
   
3.     mFile = ThisWorkbook.Path & "\1.xlsx"
   
4.     If Dir(mFile, vbNormal + vbHidden) = "" Then MsgBox "预定文件不存在！", 16 + 0, "提醒": Exit Sub
   
5.     Set wb = GetObject(mFile)  ' 后台打开
   
6.     With wb
   
7.         arr = .Sheets(1).UsedRange.Value
   
8.         .Close False
   
9.     End With
   
10.     Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    
11.     For i = 2 To UBound(arr)
    
12.         If Len(arr(i, 1)) > 0 And Not d.Exists(arr(i, 1)) Then d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 8))
    
13.     Next
    
14.     With Sheet1
    
15.         .Activate
    
16.         arr = .UsedRange.Value
    
17.         For i = 2 To UBound(arr)
    
18.             If Len(arr(i, 6)) > 0 Then
    
19.                 If d.Exists(arr(i, 6)) Then
    
20.                     For j = 0 To 3
    
21.                         arr(i, j + 7) = d(arr(i, 6))(j)
    
22.                     Next
    
23.                 Else
    
24.                     For j = 7 To 10
    
25.                         arr(i, j) = Empty
    
26.                     Next
    
27.                 End If
    
28.             End If
    
29.         Next
    
30.         .UsedRange.Value = arr
    
31.     End With
    
32.     MsgBox "数据匹配完成！", 64 + 0, "提醒"
    
33. End Sub

复制代码

xiangbaoan

………………

donghui2363

练习一下
Sub 匹配()
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    p = ThisWorkbook.Path & "\1.xlsx"
    Sql = "select b.商品名称,b.商品规格,b.生产企业,b.批准文号 from [sheet1$f1:f] a left join [" & p & "].[sheet1$] b on a.商品编码=b.商品编号"
    Range("g2").CopyFromRecordset cnn.Execute(Sql)
    cnn.Close
    Set cnn = Nothing
End Sub