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

3190496160

模板.rar (87.06 KB, 下载次数: 29)

2024-3-25 16:57 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.25
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     p = ThisWorkbook.Path & ""
   
7.     p1 = p & "源文件"
   
8.     f = p & "银行卡账户信息.xlsx"
   
9.     Set wb = Workbooks.Open(f, 0)
   
10.     With wb.Sheets(1)
    
11.         arr = .UsedRange
    
12.         wb.Close False
    
13.     End With
    
14.     For i = 2 To UBound(arr)
    
15.         s = arr(i, 1)
    
16.         d(s) = Array(arr(i, 2), arr(i, 3))
    
17.     Next
    
18.     ReDim brr(1 To 10000, 1 To 7)
    
19.     For Each f In fso.GetFolder(p1).files
    
20.         If f.name Like "*.xls*" Then
    
21.             If InStr(f.name, ThisWorkbook.name) = 0 Then
    
22.                 fn = fso.GetBaseName(f)
    
23.                 Set wb = Workbooks.Open(f, 0)
    
24.                 With wb.Sheets(1)
    
25.                     arr = .UsedRange
    
26.                     wb.Close False
    
27.                 End With
    
28.                 For i = 5 To UBound(arr)
    
29.                     If Val(arr(i, 1)) Then
    
30.                         m = m + 1
    
31.                         brr(m, 1) = arr(i, 1)
    
32.                         brr(m, 2) = arr(i, 2)
    
33.                         brr(m, 3) = arr(i, 3)
    
34.                         brr(m, 6) = arr(i, 70)
    
35.                         If d.exists(arr(i, 2)) Then
    
36.                             brr(m, 4) = CStr(d(arr(i, 2))(0))
    
37.                             brr(m, 5) = d(arr(i, 2))(1)
    
38.                         End If
    
39.                     End If
    
40.                 Next
    
41.             End If
    
42.         End If
    
43.     Next f
    
44.     If m > 0 Then
    
45.         f = p & "工资银行卡明细.xlsx"
    
46.         Set wb = Workbooks.Open(f, 0)
    
47.         With wb.Sheets(1)
    
48.             .[a4:g32].ClearContents
    
49.             .[a4].Resize(m, 6) = brr
    
50.             wb.Close 1
    
51.         End With
    
52.     End If
    
53.     Set d = Nothing
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "OK！"
    
56. End Sub
    
57. 
    

复制代码

fzxba

1. Sub test1()
   
2.   
   
3.   Dim p As String, f As String
   
4.   'Dim Conn As New ADODB.Connection, rs As New ADODB.Recordset
   
5.   Dim Conn As Object ', rs As Object
   
6.   Dim wkb As Workbook, wks As Worksheet
   
7.   Dim strConn As String, strSQL As String, SQL As String, s As String, i As Long
   
8.   
   
9.   DoApp False
   
10.   
    
11.   p = ThisWorkbook.Path
    
12.   Set wkb = Workbooks.Open(p & "\" & "工资银行卡明细.xlsx", 0)
    
13.   With wkb
    
14.     For i = .Worksheets.Count To 2 Step -1
    
15.       .Worksheets(i).Delete
    
16.     Next
    
17.     Set wks = .Worksheets(1)
    
18.   End With
    
19.   
    
20.   Set Conn = CreateObject("ADODB.Connection")
    
21.   'Set rs = CreateObject("ADODB.Recordset")
    
22.   s = "Excel 12.0;HDR=YES;Database="
    
23.   If Application.Version < 12 Then
    
24.     s = Replace(s, "12.0", "8.0")
    
25.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
26.   Else
    
27.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
28.   End If
    
29.   Conn.Open strConn & p & "\" & "银行卡账户信息.xlsx"
    
30.   
    
31.   SQL = "SELECT 收款人姓名,收款账号,`收款银行（必填）` AS 所属银行 FROM [$A1:C] WHERE 收款人姓名 IS NOT NULL"
    
32.   
    
33.   p = Left(p, InStrRev(p, "\")) & "源文件\"
    
34.   f = Dir(p & "*.xls?")
    
35.   While Len(f)
    
36.     If ThisWorkbook.FullName <> p & f Then
    
37.       strSQL = "SELECT 员工工号,员工姓名,职位,实发工资 FROM [" & s & p & f & "].[$A3:BR] WHERE 员工姓名 IS NOT NULL"
    
38.       strSQL = "SELECT a.员工工号,a.员工姓名,a.职位,b.收款账号,b.所属银行,a.实发工资 FROM (" & strSQL & ") a LEFT JOIN (" & SQL & ") b ON a.员工姓名=b.收款人姓名"
    
39.       With wkb
    
40.         wks.Copy After:=.Worksheets(.Worksheets.Count)
    
41.         With .Worksheets(.Worksheets.Count)
    
42.           .Range("A4").CopyFromRecordset Conn.Execute(strSQL)
    
43.           .name = Split(f, ".xls")(0)
    
44.         End With
    
45.       End With
    
46.     End If
    
47.     f = Dir
    
48.   Wend
    
49.   wkb.Close True
    
50.   
    
51.   Set wks = Nothing
    
52.   Set wkb = Nothing
    
53.   Conn.Close
    
54.   Set Conn = Nothing
    
55.   DoApp
    
56.   Beep
    
57. End Sub
    
58. 
    
59. Function DoApp(Optional b As Boolean = True)
    
60.   With Application
    
61.     .ScreenUpdating = b
    
62.     .DisplayAlerts = b
    
63.     .Calculation = -b * 30 - 4135
    
64.   End With
    
65. End Function

复制代码

fzxba

测试.zip (105.77 KB, 下载次数: 32)

2024-3-25 21:47 上传

点击文件名下载附件

zjz0808

fzxba 发表于 2024-3-25 21:47

测试成功，非常好用， 万分感谢

fzxba

zjz0808 发表于 2024-3-26 10:01
测试成功，非常好用， 万分感谢

1. Sub test1()  '好吧，更新一下，提供更多选择……
   
2.   
   
3.   'Dim Conn As New ADODB.Connection, rs As New ADODB.Recordset
   
4.   Dim Conn As Object ', rs As Object
   
5.   Dim wkb As Workbook, wks As Worksheet
   
6.   Dim strConn As String, strSQL As String, SQL As String, s As String, i As Long
   
7.   Dim p As String, f As String, strPath As String
   
8.   
   
9.   DoApp False
   
10.   
    
11.   strPath = ThisWorkbook.Path
    
12.   
    
13.   With Application.FileDialog(msoFileDialogFolderPicker)
    
14.     .InitialFileName = Left(strPath, InStrRev(strPath, "\"))
    
15.     If .Show Then p = .SelectedItems(1) Else GoTo Line0
    
16.   End With
    
17.   If Right(p, 1) <> "\" Then p = p & "\"                                                '此为选择 源文件 路径
    
18.                                 
    
19.   
    
20.   'p = Left(strPath, InStrRev(Left(strPath, Len(strPath) - 1), "\")) & "源文件\"        '这里直接指定 源文件 路径，适用于提供附件 文件夹结构
    
21.                                 
    
22.   
    
23.   strPath = strPath & "\"                                                               '若另存为工作簿，这里是另存路径
    
24.                                 
    
25.   
    
26.   'Set rs = CreateObject("ADODB.Recordset")
    
27.   Set Conn = CreateObject("ADODB.Connection")
    
28.   s = "Excel 12.0;HDR=YES;Database="
    
29.   If Application.Version < 12 Then
    
30.     s = Replace(s, "12.0", "8.0")
    
31.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
32.   Else
    
33.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
34.   End If
    
35.   Conn.Open strConn & strPath & "银行卡账户信息.xlsx"
    
36.   
    
37.   Set wkb = Workbooks.Open(strPath & "工资银行卡明细.xlsx", 0)
    
38.   With wkb
    
39.     For i = .Worksheets.Count To 2 Step -1
    
40.       .Worksheets(i).Delete
    
41.     Next
    
42.     Set wks = .Worksheets(1)
    
43.   End With
    
44.   
    
45.   
    
46.   SQL = "SELECT 收款人姓名,收款账号,`收款银行（必填）` AS 所属银行 FROM [$A1:C] WHERE 收款人姓名 IS NOT NULL"
    
47.   strSQL = "SELECT 员工工号,员工姓名,职位,实发工资 FROM [" & s & p & "[.f]].[门店工资汇总$A3:BR] WHERE 员工姓名 IS NOT NULL"
    
48.   strSQL = "SELECT a.员工工号,a.员工姓名,a.职位,b.收款账号,b.所属银行,a.实发工资 FROM (" & strSQL & ") a LEFT JOIN (" & SQL & ") b ON a.员工姓名=b.收款人姓名"
    
49.   
    
50.   f = Dir(p & "*.xls*")
    
51.   While Len(f)
    
52.     If ThisWorkbook.FullName <> p & f Then
    
53.       
    
54.       '''''''''''''''''''''''''''''''''''''''''''''''''''下段另存为 工作簿
    
55. '      wks.Copy
    
56. '      With ActiveWorkbook
    
57. '        With .Worksheets(1)
    
58. '          .Range("A4").CopyFromRecordset Conn.Execute(Replace(strSQL, "[.f]", f))
    
59. '          .Name = Split(f, ".xls")(0)
    
60. '        End With
    
61. '        .SaveAs strPath & Split(f, ".xls")(0), 51
    
62. '        .Close
    
63. '      End With
    
64.       '''''''''''''''''''''''''''''''''''''''''''''''''''上段另存为 工作簿
    
65.       
    
66.       
    
67.       '''''''''''''''''''''''''''''''''''''''''''''''''''下段在原工作簿中创建新 工作表
    
68.       With wkb
    
69.         wks.Copy After:=.Worksheets(.Worksheets.Count)
    
70.         With .Worksheets(.Worksheets.Count)
    
71.           .Range("A4").CopyFromRecordset Conn.Execute(Replace(strSQL, "[.f]", f))
    
72.           .Name = Split(f, ".xls")(0)
    
73.         End With
    
74.       End With
    
75.       '''''''''''''''''''''''''''''''''''''''''''''''''''上段在原工作簿中创建新 工作表
    
76.       
    
77.     End If
    
78.     f = Dir
    
79.   Wend
    
80.   
    
81.   wkb.Close True
    
82.   Set wks = Nothing
    
83.   Set wkb = Nothing
    
84.   Conn.Close
    
85.   Set Conn = Nothing
    
86. Line0:
    
87.   DoApp
    
88.   Beep
    
89. End Sub
    
90. 
    
91. Function DoApp(Optional b As Boolean = True)
    
92.   With Application
    
93.     .ScreenUpdating = b
    
94.     .DisplayAlerts = b
    
95.     .Calculation = -b * 30 - 4135
    
96.   End With
    
97. End Function

复制代码

h2016

数据按照特定格式输出

h2016

批量的数据看看