如何用VBA实现批量文件夹表格里面特定的数据获取并按照模板自动生成新文件

zjz0808

“门店工资汇总.xlsx”是源文件，源文件数量不定，“工资银行卡明细.xlsx”是生成文件的模板
如下面两个表，现在需要通过选择源文件的文件夹多个表里面的“门店工资汇总”里面
A5:A13的数据复制到“工资银行卡明细”A4：A12；
B5:B13的数据复制到“工资银行卡明细”B4:B11；
C5:C13的数据复制到“工资银行卡明细”C4:C11；
BR5:BR13的数据复制到“工资银行卡明细”F4:F11，

同时收款账号，所属银行需要通过名字来从另外一个指定的工作薄“银行卡账户信息”里面sheet1表里面获取数据模板（银行信息的表头是：姓名，银行账户，开户行）里面其他内容不变；，在不打开“工资银行卡明细.xlsx”模板的情况下或者其他文件的情况下，生成的数据以源文件名保存存在模板的子表中；（有多少个源文件生成多少个子表）


附件里面是模板以及源文件的文件夹，
模板文件夹，是我自己写的VBA代码但是实现不了。！

请大佬们帮忙重新写个或者帮我修改下！万分感谢各位了，辛苦了，谢谢！


我用的是office2010版本

如果有不明白的，留言，我解释下！

LIUZHU

没有附件吗？

zjz0808

LIUZHU 发表于 2024-3-25 15:20
没有附件吗？

有的，我刚不小心发送了， 我修改了下， 你帮忙看下呢

LIUZHU

不能打开原始文件，还是等高人用SQL来解决把

zjz0808

LIUZHU 发表于 2024-3-25 15:37
不能打开原始文件，还是等高人用SQL来解决把

你能用VBA重新写吗

LIUZHU

zjz0808 发表于 2024-3-25 15:38
你能用VBA重新写吗

不能打开原文件的话，比较麻烦，不好提取人员信息

zjz0808

LIUZHU 发表于 2024-3-25 15:39
不能打开原文件的话，比较麻烦，不好提取人员信息

我调试了下， 只能复制到一列，其他的就不行， 然后银行就不能获取信息了，刚看下了，是我的VBA里面模板路径设定的不对， 我重新改了， ，而且生成的是新的表格， 并不在模板的子表里面
你说的不能打开源文件的话是什么意思？

3190496160

没有多大难度，但是，涉及到的文件较多，比较繁琐，工作量不小，先留个记号吧

zjz0808

3190496160 发表于 2024-3-25 16:29
没有多大难度，但是，涉及到的文件较多，比较繁琐，工作量不小，先留个记号吧

先感谢大哥！

3190496160

Sub 批量生成()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "银行卡账户信息.xlsx")
ff = Dir(lj & "工资银行卡明细.xlsx")
If f = "" Then MsgBox "找不到银行卡账户信息文件！": End
If ff = "" Then MsgBox "找不到工资银行卡明细文件！": End
Set wb = Workbooks.Open(lj & f, 0)
With wb.Worksheets(1)
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range(.Cells(1, 1), .Cells(r, 3))
End With
wb.Close False
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        d(ar(i, 1)) = i
    End If
Next i
Set f = Nothing
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0) '浏览文件对话框
If obmapp Is Nothing Then End '如果对话框选择了  确定  按钮
fp = obmapp.Self.Path & "\" '取得选择的文件夹的路径
f = Dir(fp & "*.xls*")
Do While f <> "" ''在目录中循环
    Set wb = Workbooks.Open(fp & f) '打开文件
    With wb.Worksheets(1) '再打开文件的第一个工作表循环
        rs = .Cells(Rows.Count, 2).End(xlUp).Row
        br = .Range("a5:br" & rs)
    End With
    wb.Close False
    n = 0
    ReDim arr(1 To UBound(br), 1 To 6)
    For i = 1 To UBound(br)
        n = n + 1
        For j = 1 To 3
            arr(n, j) = br(i, j)
        Next j
        arr(n, 6) = br(i, 70)
        xh = d(br(i, 2))
        If xh <> "" Then
            arr(n, 4) = ar(xh, 2)
            arr(n, 5) = ar(xh, 3)
        End If
    Next i
    Set ww = Workbooks.Open(lj & ff, 0) '打开文件
    With ww.Worksheets(1)
        .[a4].Resize(n, UBound(arr, 2)) = arr
    End With
    ww.SaveAs Filename:=lj & f
    ww.Close
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub