大神，求助VBA代码！！！ 将指定文件夹中所有工作薄某一列数据一对一的写入汇总表...

观苍山游洱海

需求：文件夹中有不同名称的工作薄（若干个），里面标题、内容相同，由于不是同一部门填写，案例中1，2，3工作薄G列有的空白，有的有数据，现需要将该文件夹中的所有工作薄中G列数据全部汇总到汇总表中，其余内容不变，让其成为一个完整的工作薄。简单说就是：一键将1，2，3工作薄中G列数据一对一的填写到汇总表中的G列。
PS：文件夹位置：C:\Users\admin\Desktop  ，工作薄中 《业务编号》 为唯一值

3190496160

Sub 批量汇总()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:g" & r)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            d(Trim(ar(i, 2))) = i
        End If
    Next i
    lj = ThisWorkbook.Path & "\"
    f = Dir(lj & "\*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(lj & "\" & f, 0)
            With wb.Worksheets(1)
                rs = .Cells(Rows.Count, 1).End(xlUp).Row
                br = .Range("a1:g" & rs)
            End With
            For i = 2 To UBound(br)
                If Trim(br(i, 2)) <> "" And Trim(br(i, 7)) <> "" Then
                    xh = d(Trim(br(i, 2)))
                    If xh <> "" Then
                        ar(xh, 7) = br(i, 7)
                    End If
                End If
            Next i
            wb.Close False
        End If
    f = Dir
    Loop
     .Range("a1:g" & r) = ar
End With
Application.ScreenUpdating = True
MsgBox "批量汇总完毕!"
End Sub

3190496160

3190496160

案例.rar (40 KB, 下载次数: 20)

2023-3-1 18:04 上传

点击文件名下载附件

简七

1. Option Explicit
   
2. Private Function GetSelectSQLString()
   
3.     Dim filePath$, folderPath$, FileDialog
   
4.    
   
5.     Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
   
6.    
   
7.     FileDialog.Title = "请选择数据文件夹"
   
8.    
   
9.     FileDialog.Show
   
10.    
    
11.     If FileDialog.SelectedItems.Count = 0 Then
    
12.    
    
13.         Set FileDialog = Nothing
    
14.         
    
15.         GetSelectSQLString = ""
    
16.         
    
17.         Exit Function
    
18.     End If
    
19.    
    
20.     folderPath = FileDialog.SelectedItems(1)
    
21.    
    
22.     filePath = Dir(folderPath & "\*.xls*")
    
23.    
    
24.     Dim sqlDic As Object
    
25.    
    
26.     Set sqlDic = CreateObject("scripting.dictionary")
    
27.    
    
28.     While filePath <> ""
    
29.    
    
30.         sqlDic(filePath) = "select 借款人,业务编号,发放金额,发放日期,到期日期,余额,cdbl(预计收回金额) as 预计收回金额 From [excel 12.0;imex=1;database=" & folderPath & "" & filePath & "].[Sheet1$] where 预计收回金额 is not null"
    
31.         
    
32.         filePath = Dir()
    
33.         
    
34.     Wend
    
35.    
    
36.     GetSelectSQLString = Join(sqlDic.items, " union ")
    
37.    
    
38.     Set sqlDic = Nothing
    
39.    
    
40.     Set FileDialog = Nothing
    
41. End Function
    
42. 
    
43. 
    
44. Sub demo()
    
45. 
    
46.     Dim conn As Object, rs As Object, sqlString$
    
47.    
    
48.     sqlString = GetSelectSQLString
    
49.    
    
50.     If InStr(sqlString, "select") < 0 Then Exit Sub
    
51.    
    
52.     Set conn = CreateObject("adodb.connection")
    
53.    
    
54.     Set rs = CreateObject("adodb.recordset")
    
55.    
    
56.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='excel 12.0;HDR=YES;imex=2';Data Source=" & ThisWorkbook.FullName
    
57.    
    
58.     '可以注释掉直接使用返回的SQL语句
    
59.     sqlString = "select Summary.借款人,Summary.业务编号,Summary.发放金额,Summary.发放日期,Summary.到期日期,Summary.余额,temp.预计收回金额 From [Sheet1$] as Summary Left Join (" & sqlString & ") as temp on Summary.借款人=temp.借款人 and Summary.业务编号=temp.业务编号 and Summary.发放金额=temp.发放金额 and Summary.发放日期=temp.发放日期 and Summary.到期日期=temp.到期日期 and Summary.余额=temp.余额"
    
60.    
    
61.     rs.Open sqlString, conn
    
62.    
    
63.     ThisWorkbook.Worksheets(1).Range("a2").CopyFromRecordset rs
    
64.    
    
65.     Set rs = Nothing
    
66.    
    
67.     Set conn = Nothing
    
68.    
    
69. End Sub

复制代码

简七

..............................附件

观苍山游洱海

3190496160 发表于 2023-3-1 18:03
Sub 批量汇总()
Application.ScreenUpdating = False
Dim d As Object

感谢大神的慷慨救助！

观苍山游洱海

简七 发表于 2023-3-1 19:01

同样感谢大神的帮忙，辛苦，我还得向大神们学习！