如何用VBA实现批量文件夹表格里面特定的数据获取并复制到指定的表中

Question

“门店工资汇总.xlsx”是源文件，“工资银行卡明细.xlsx”是生成文件的模板
如下面两个表，现在需要通过选择源文件的文件夹把同一个文件夹里面多个表里面的“门店工资汇总”里面A5:A12的数据复制到“工资银行卡明细”A4开始； B5:B12的数据复制到“工资银行卡明细”B4开始； C5:C12的数据复制到“工资银行卡明细”C4开始；BR5:BR12的数据复制到“工资银行卡明细”F4开始，同时收款账号，所属银行需要通过名字来从另外一个指定的工作薄“银行卡账户信息”里面sheet1表里面获取数据模板（银行信息的表头是：姓名，银行账户，开户行）里面其他内容不变；，在不打开“工资银行卡明细.xlsx”模板的情况下或者其他文件的情况下，生成的xlsx表格以源文件同样的文件名另存在源文件的子文件夹中，子文件命名为“数据汇总”；

需要用VBA来解答这个问题，谢谢

Answer 1

让阿豪来帮你解答，本回答参考chatgpt3.5编写提供，如果还有疑问可以评论或留言

问题分析： 首先需要将同一个文件夹里面的多个表中“门店工资汇总”中指定范围的数据复制到“工资银行卡明细”表的指定位置，同时需要从另外一个指定的工作薄“银行卡账户信息”里面获取数据模板，并将数据填充到“工资银行卡明细”表中的指定位置。 解决方案：

1. 遍历同一个文件夹里面的多个表
2. 找到“门店工资汇总”这个表
3. 复制指定范围的A5:A12、B5:B12、C5:C12、BR5:BR12数据到“工资银行卡明细”表的指定位置
4. 根据名字在“银行卡账户信息”表找到对应的银行信息
5. 将银行信息填充到“工资银行卡明细”表的指定位置 示例代码：

Sub CopyData()
    Dim folderPath As String
    Dim filePath As String
    Dim wb As Workbook
    Dim wsSalary As Worksheet
    Dim wsBank As Worksheet
    Dim bankDict As Object
    Dim nameRange As Range
    Dim accountRange As Range
    Dim branchRange As Range
    Dim i As Integer
    
    '设置文件夹路径
    folderPath = "C:\Users\UserName\Documents\Salary"
    
    '创建银行信息字典
    Set bankDict = CreateObject("Scripting.Dictionary")
    Set wsBank = Workbooks("银行卡账户信息.xlsx").Sheets("Sheet1")
    For i = 2 To wsBank.Range("A" & Rows.Count).End(xlUp).Row
        bankDict(wsBank.Range("A" & i).Value) = Array(wsBank.Range("B" & i).Value, wsBank.Range("C" & i).Value)
    Next i
    
    '遍历文件夹中的多个表
    filePath = Dir(folderPath & "\*.xlsx")
    Do While filePath <> ""
        Set wb = Workbooks.Open(folderPath & "\" & filePath)
        '找到"门店工资汇总"表
        On Error Resume Next
        Set wsSalary = wb.Sheets("门店工资汇总")
        On Error GoTo 0
        If Not wsSalary Is Nothing Then
            With Workbooks("工资银行卡明细.xlsx").Sheets("工资银行卡明细")
                '复制数据到指定位置
                .Range("A4:A11").Value = wsSalary.Range("A5:A12").Value
                .Range("B4:B11").Value = wsSalary.Range("B5:B12").Value
                .Range("C4:C11").Value = wsSalary.Range("C5:C12").Value
                .Range("F4:F11").Value = wsSalary.Range("BR5:BR12").Value
                '根据名字查找银行信息，并填充到指定位置
                For i = 4 To 11
                    If bankDict.Exists(.Range("B" & i).Value) Then
                        .Range("C" & i).Value = bankDict(.Range("B" & i).Value)(0)
                        .Range("D" & i).Value = bankDict(.Range("B" & i).Value)(1)
                    End If
                Next i
            End With
        End If
        wb.Close False
        filePath = Dir()
    Loop
    
    '清空变量
    Set wb = Nothing
    Set wsSalary = Nothing
    Set wsBank = Nothing
    Set bankDict = Nothing
    Set nameRange = Nothing
    Set accountRange = Nothing
    Set branchRange = Nothing
End Sub