VBA怎么在同一目录下跨工作簿实现index +match功能或者vlookup功能

zyali1006

昨天研究一下午，今天又看了半天，还是没有头绪。


问题：VBA怎么在同一目录下跨工作簿实现index +match功能或者vlookup功能

1、注意必须是同一个目录下，因为每个月路径不一样。不能再去导入表格，也不能每月改路径，要在同一目录下，可以一键控件的操作代码。

2、两个工作簿命名的月份会变化，比如这个月是“源数据2023.7”，下个月是“源数据2023.8”，那么源数据规则为含“源数据”的文件名。

3、操作代码在目标工作簿，即含“写入表”的工作簿的“sheet2”里边。但实际写入位置是“写入表2023.7”的'sheet1"

4、必须是跨工作簿的不同sheet实现index +match，同一个目录下，两个工作簿不同名，两个sheet名字也可能不一样。

跨工作簿才必须要用VBA才省心，同一个工作簿我就用公式不用VBA了。


网上有些是用到SQL链接，有些用字典，一个都无法代入实现。
问AI得到的代码也无法实现。

有没有大神可以路过指导下，非常感谢。

同一目录下的两个工作簿

源数据

shiruiqiang

字典，instr，遍历工作簿。基本搞定

zyali1006

shiruiqiang 发表于 2023-7-12 15:37
字典，instr，遍历工作簿。基本搞定

我看好多人都回复跨工作簿匹配很简单，但网上真的找不到一个类似可以代入运行成功的例子呢。
可以具体说说吗？

qdtzq

感觉用sql,一个左连接，搞定

zyali1006

qdtzq 发表于 2023-7-12 15:56
感觉用sql,一个左连接，搞定

是的，网上主要是这两个逻辑，字典或者SQL。比如这个就是用的SQL吧。https://club.excelhome.net/threa ... tml?_dsign=6a77b06f
但是我一开始代入报错，好不容易弹框运行成功，就是没有数据出来。
这个SQL是excel自带的，还是要安装SQL才能运行呢？

feilanga

.....................

3190496160

Sub 导入()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set sht = Sheets("sheet1")
f = Dir(ThisWorkbook.Path & "\源数据*.xls*")
If f = "" Then MsgBox "找不到源数据文件！": End
With sht
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r >= 3 Then .Range(.Cells(3, 1), .Cells(r, y)) = Empty
    ar = .Range(.Cells(2, 1), .Cells(100000, y))
    For j = 3 To UBound(ar, 2)
        If Trim(ar(1, j)) <> "" Then
            d(Trim(ar(1, j))) = j
        End If
    Next j
    n = 1
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
    With wb.Worksheets(1)
        br = .UsedRange.Offset(3)
    End With
    wb.Close False
    For i = 2 To UBound(br)
        If Trim(br(i, 2)) <> "" Then
            n = n + 1
            ar(n, 1) = n - 1
            ar(n, 2) = br(i, 2)
            For j = 2 To UBound(br, 2)
                If Trim(br(1, j)) <> "" Then
                    lh = d(Trim(br(1, j)))
                    If lh <> "" Then
                        ar(n, lh) = br(i, j)
                    End If
                End If
            Next j
        End If
    Next i
    If n = 1 Then MsgBox "源数据为空！": End
    .Cells(2, 1).Resize(n, UBound(ar, 2)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

新建文件夹.rar (27.23 KB, 下载次数: 41)

2023-7-12 16:14 上传

点击文件名下载附件

feilanga

1. Sub CX() ' 将多个源数据文件中的信息提取到当前工作簿的Sheet1中
   
2.     Dim arr, brr '定义变量
   
3.     Application.ScreenUpdating = False '屏幕刷新关闭
   
4.     Set dic = CreateObject("Scripting.Dictionary") ' 创建字典对象
   
5.     p = ThisWorkbook.Path & "" ' 获取当前工作簿的路径
   
6.     f = Dir(p & "*.xls*") ' 获取指定路径下的所有xls文件
   
7.     Do While f <> "" ' 遍历每个文件
   
8.         If f <> ThisWorkbook.Name And InStr(f, "源数据") Then ' 排除当前工作簿并指定包含"源数据"名称的文件
   
9.             Set wb = Workbooks.Open(p & f, 0) ' 打开文件
   
10.             For Each sht In wb.Sheets ' 遍历每个工作表
    
11.                 If sht.Index > 0 Then ' 排除空表
    
12.                     arr = sht.UsedRange ' 源数据装入数组
    
13.                     For i = 5 To UBound(arr) ' 遍历每一行（从第5行开始）
    
14.                         Key = arr(i, 1) ' 关键字姓名
    
15.                         Set dic(Key) = CreateObject("scripting.dictionary") ' 创建嵌套字典对象，并将其添加到主字典中
    
16.                         For j = 2 To UBound(arr, 2) ' 遍历每一列（从第2列开始）
    
17.                             key2 = arr(4, j) ' 关键字学科名称
    
18.                             dic(Key)(key2) = arr(i, j) ' 将对应的数值存储到嵌套字典中
    
19.                         Next j
    
20.                     Next i
    
21.                 End If
    
22.             Next sht
    
23.             wb.Close False ' 关闭文件，不保存更改
    
24.         End If
    
25.         f = Dir ' 获取下一个文件
    
26.     Loop
    
27.     brr = Sheet1.UsedRange '查询表装入数组
    
28.     For i = 3 To UBound(brr) ' 遍历Sheet1中的每一行和列（从第3行和第3列开始）
    
29.         For j = 3 To UBound(brr, 2)
    
30.             If VBA.IsEmpty(brr(i, 2)) Then Exit For ' 如果第二列为空，则跳出内层循环
    
31.             Key = brr(i, 2) '关键字=姓名
    
32.             key2 = brr(2, j) '关键字=学科
    
33.             If dic(Key).Exists(key2) Then ' 如果主字典中存在关键字和嵌套字典中存在关键字，
    
34.                 brr(i, j) = dic(Key)(key2) '则将对应的数值赋给数组
    
35.             End If
    
36.         Next j
    
37.     Next i
    
38.     Sheet1.UsedRange = brr '数组重新输出到单元格
    
39.     Application.ScreenUpdating = True '屏幕刷新开启
    
40. End Sub

复制代码