怎么用VBA把压缩文件中的表格合并在一张表里

jin2001h

怎么把多个压缩文件中的表格合并在一张总表里，效果如16日总表，谢谢各位大拿

smsn

1 压缩格式只有zip? rar 7z 等没有用吧？不加密吧？用什么压缩软件生成？自带zip,winrar,7zip,其他？
2 压缩文件内存在子目录吗？ xlsx文件只放在压缩包内，没建目录吧？压缩包内会有多个文件吧？
3 合并的只有 xlsx 格式，有其他格式吗？


根据你现有条件简单写了一个。

1. Sub unzipNcombine()
   
2.     Dim FSO As Object, oApp As Object, fname As Variant, FileNameFolder As Variant, DefPath As String, strDate As String, I As Long, num As Long, J As Long, ListinZIP() As String
   
3.     fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=True)
   
4.     If IsArray(fname) = False Then
   
5.     Else
   
6.         DefPath = Application.DefaultFilePath 'DefPath = "C:\Users\aaa\test" '自定解压文件夹
   
7.         If Right(DefPath, 1) <> "" Then
   
8.             DefPath = DefPath & ""
   
9.         End If
   
10.         strDate = Format(Now, " dd-mm-yy h-mm-ss")
    
11.         FileNameFolder = DefPath & "MyUnzipFolder " & strDate & ""
    
12.         MkDir FileNameFolder
    
13.         Set oApp = CreateObject("Shell.Application")
    
14.         For I = LBound(fname) To UBound(fname)
    
15.             num = oApp.Namespace(FileNameFolder).Items.Count
    
16.             oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fname(I)).Items
    
17.             For Each Item In oApp.Namespace(fname(I)).Items
    
18.                 J = J + 1
    
19.                 Dim orgnName As String, destName As String
    
20.                 orgnName = FileNameFolder & Item.Name: destName = FileNameFolder & Split(Dir(fname(I)), ".")(0) & "." & Item.Name
    
21.                 Name orgnName As destName
    
22.             Next
    
23.         Next I
    
24.         On Error Resume Next
    
25.         Set FSO = CreateObject("scripting.filesystemobject")
    
26.         FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    
27.     End If
    
28.     Shell "explorer.exe " & FileNameFolder, vbNormalFocus
    
29.     'Combine files
    
30.     Dim title_row As Integer, last_col As String, not_null_col As Integer, from_path As String, to_path As String, wb As Workbook, n As Integer, temparr, shopname(), lastrow As Integer
    
31.     '
    
32.     title_row = 1    '定义标题行所在行号
    
33.     last_col = "E"   '定义区域尾列所在列名
    
34.     from_path = FileNameFolder:     to_path = FileNameFolder
    
35.     Application.ScreenUpdating = False
    
36.     fname = Dir(from_path)
    
37.     Set wb = Workbooks.Add
    
38.     '
    
39.     With wb.Sheets(1)
    
40.         Columns(1).NumberFormat = "@":        Columns(3).NumberFormat = "m/d/yyyy"
    
41.         Range("A1:E1") = Split("店铺,单号,下单时间,订单,客户", ",")
    
42.         Do While fname <> ""
    
43.             Workbooks.Open Filename:=from_path & fname:            Rows("1:1").Clear
    
44.             temparr = Sheets(1).UsedRange
    
45.             ReDim shopname(1 To UBound(temparr, 1) + 1, 1 To 1)
    
46.             Workbooks(fname).Close SaveChanges:=False
    
47.             lastrow = Cells(Rows.Count, 2).End(xlUp).Row + 1
    
48.             Range("B" & lastrow).Resize(UBound(temparr, 1), 4) = temparr
    
49.             Range("A" & lastrow & ":A" & lastrow + UBound(temparr, 1) - 1) = Split(fname, ".")(0)
    
50.             fname = Dir()
    
51.         Loop
    
52.     End With
    
53.     Cells.EntireColumn.AutoFit:    wb.SaveAs Filename:=to_path & "CombinF.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
54.     Application.ScreenUpdating = True
    
55.     'MsgBox "Done", vbOK
    
56. End Sub

复制代码

fzxba

1. Sub Main()
   
2.   Dim strPath As String, strZipFile As String, vZipFilesList() As String, iCount As Integer
   
3. 
   
4.   strPath = ThisWorkbook.Path & "\"
   
5.   strZipFile = Dir(strPath & "*.zip")
   
6.   While Len(strZipFile)
   
7.     UnZipFiles strPath, strZipFile, vZipFilesList, iCount
   
8.     strZipFile = Dir
   
9.   Wend
   
10.   If iCount = 0 Then Exit Sub
    
11. 
    
12.   Dim Fso As Object, vExcelFiles() As String, vFoldersList() As String
    
13.   Dim i As Long, j As Long, k As Long, n As Long
    
14.   Set Fso = CreateObject("Scripting.FileSystemObject")
    
15. 
    
16.   For i = 1 To UBound(vZipFilesList)
    
17.     If InStr(Dir(vZipFilesList(i), vbDirectory), ".xls") Then
    
18.       n = n + 1
    
19.       ReDim Preserve vExcelFiles(1 To n)
    
20.       vExcelFiles(n) = vZipFilesList(i)
    
21.     Else
    
22.       GetExcelFiles vZipFilesList(i), Fso, vExcelFiles, n
    
23.       k = k + 1
    
24.       ReDim Preserve vFoldersList(1 To k)
    
25.       vFoldersList(k) = vZipFilesList(i)
    
26.     End If
    
27.   Next
    
28.   Dim Conn As Object, rs As Object, Dict As Object, Cel As Range, vTemp, Flag As Boolean
    
29.   Dim strConn As String, SQL As String, strFields As String, s As String, vFields() As String
    
30. 
    
31.   ActiveSheet.UsedRange.ClearContents
    
32.   Application.ScreenUpdating = False
    
33. 
    
34.   Set Cel = Range("A2")
    
35.   Set Dict = CreateObject("Scripting.Dictionary")
    
36.   Set Conn = CreateObject("ADODB.Connection")
    
37. 
    
38.   s = "Excel 12.0;HDR=yes;Database="
    
39.   If Application.Version < 12 Then
    
40.     s = Replace(s, "12.0", "8.0")
    
41.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
42.   Else
    
43.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
44.   End If
    
45.   Conn.Open strConn & ThisWorkbook.FullName
    
46. 
    
47.   For i = 1 To UBound(vExcelFiles)
    
48.     If i = 1 Then
    
49.       Set rs = Conn.Execute("SELECT * FROM [" & s & vExcelFiles(i) & "].[$A1:E] WHERE FALSE")
    
50.       ReDim vFields(rs.Fields.Count)
    
51.       vFields(0) = "'" & Mid(vExcelFiles(i), InStrRev(vExcelFiles(i), "") + 1) & "' AS 文件名"
    
52.       For j = 1 To rs.Fields.Count
    
53.         vFields(j) = "[" & rs.Fields(j - 1).Name & "]"
    
54.       Next
    
55.     End If
    
56.     SQL = "SELECT " & Join(vFields, ",") & " FROM [" & s & vExcelFiles(i) & "].[$A1:E] WHERE LEN(" & vFields(1) & ")"
    
57.     Dict.Add SQL, vbNullString
    
58.     If Dict.Count = 49 Then
    
59.       Set rs = Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
60.       If Not Flag Then
    
61.         For j = 0 To rs.Fields.Count - 1
    
62.           Cel.Offset(-1, j) = rs.Fields(j).Name
    
63.         Next
    
64.         Flag = True
    
65.       End If
    
66.       Cel.CopyFromRecordset rs
    
67.       Set Cel = Cel.End(xlDown).Offset(1)
    
68.       Dict.RemoveAll
    
69.     End If
    
70.   Next
    
71.   If Dict.Count Then
    
72.     Set rs = Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
73.     If Not Flag Then
    
74.       For j = 0 To rs.Fields.Count - 1
    
75.         Cel.Offset(-1, j) = rs.Fields(j).Name
    
76.       Next
    
77.     End If
    
78.     Cel.CopyFromRecordset rs
    
79.   End If
    
80. 
    
81.   Set rs = Nothing
    
82.   Conn.Close
    
83.   Set Conn = Nothing
    
84.   Set Cel = Nothing
    
85.   Set Dict = Nothing
    
86. 
    
87.   Application.ScreenUpdating = True
    
88.   Beep
    
89. 
    
90.   For i = 1 To UBound(vExcelFiles)
    
91.     Fso.DeleteFile vExcelFiles(i), True
    
92.   Next
    
93. 
    
94.   If k Then
    
95.     For j = 1 To UBound(vFoldersList)
    
96.       Fso.DeleteFolder vFoldersList(j), True
    
97.     Next
    
98.   End If
    
99. 
    
100.   Set Fso = Nothing
     
101. End Sub
     
102. 
     
103. Function UnZipFiles(strPath As String, strZipFile As String, vZipFilesList() As String, iCount As Integer)
     
104.   Dim objFolder As Object
     
105.   Dim objFolderItem As Object
     
106.   Dim objFolderItemVerbs As Object
     
107.   If Len(strZipFile) Then
     
108.     Dim objShell As Object
     
109.     Set objShell = CreateObject("Shell.Application")
     
110.     With objShell
     
111.       Set objFolder = .Namespace(strPath & strZipFile)
     
112.       With objFolder.ParentFolder
     
113.         .CopyHere objFolder.Items, 4 + 16
     
114.       End With
     
115.     End With
     
116.     Set objFolder = Nothing
     
117. 
     
118.     GetAllZipFilesList objShell, strPath & strZipFile, vZipFilesList, iCount
     
119. 
     
120.     Set objShell = Nothing
     
121.   End If
     
122. End Function
     
123. 
     
124. Function GetAllZipFilesList(objShell As Object, strZipFile, vZipFilesList() As String, iCount As Integer)
     
125.   Dim objItem As Object
     
126.   For Each objItem In objShell.Namespace(strZipFile).Items
     
127.     iCount = iCount + 1
     
128.     ReDim Preserve vZipFilesList(1 To iCount)
     
129.     vZipFilesList(iCount) = Left(strZipFile, InStrRev(strZipFile, "")) & objItem.Name
     
130.   Next
     
131. End Function
     
132. 
     
133. Function GetExcelFiles(strPath As String, objFso As Object, vExcelFiles() As String, n As Long)
     
134.   Dim objSubFolder, objExcelFile
     
135.   For Each objExcelFile In objFso.GetFolder(strPath).Files
     
136.     If InStr(objExcelFile.Name, ".xls") Then
     
137.       n = n + 1
     
138.       ReDim Preserve vExcelFiles(1 To n)
     
139.       vExcelFiles(n) = objExcelFile.Path
     
140.     End If
     
141.   Next
     
142.   For Each objSubFolder In objFso.GetFolder(strPath).SubFolders
     
143.     GetExcelFiles objSubFolder.Path, objFso, vExcelFiles, n
     
144.   Next
     
145. End Function

复制代码

fzxba

更改51行放在55行后.rar (45.64 KB, 下载次数: 17)

2022-11-17 18:49 上传

点击文件名下载附件

审核效率还可以(2h)

smsn

smsn 发表于 2022-11-17 08:09
1 压缩格式只有zip? rar 7z 等没有用吧？不加密吧？用什么压缩软件生成？自带zip,winrar,7zip,其他？
2 压 ...

49行留了个开关控制首列内容:
= Split(fname, ".")(0)  '显示店名
= Split(fname, ".")(1)  '显示文件名
=Split(fname, ".")(1) & "." & Split(fname, ".")(2) ' 显示文件名+扩展名
=fname '显示 店名.文件名.扩展名

wengjl

fzxba 发表于 2022-11-17 16:45
审核效率还可以(2h)

是什么样的回复，会触发论坛的审核？

smsn

wengjl 发表于 2022-11-18 08:48
是什么样的回复，会触发论坛的审核？

出现了某些字符吧