使用数组进行多工作簿多表合并

ykcbf1100

copy法合并。。。

1. Sub ykcbf2()  '//2024.6.21  copy法
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set sh = ThisWorkbook.Sheets(1)
   
6.     sh.UsedRange.Clear
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.             fn = fso.GetBaseName(f)
    
11.             m = m + 1
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets(1)
    
14.                 r = IIf(m = 1, 1, sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row)
    
15.                 .UsedRange.Offset(IIf(m = 1, 0, 1)).Copy sh.Cells(r, 1)
    
16.                 wb.Close 0
    
17.             End With
    
18.         End If
    
19.     Next f
    
20.     Application.ScreenUpdating = True
    
21.     MsgBox "汇总完毕!"
    
22. End Sub
    

复制代码

wang-way

试试我这个 秒完成

sero61

wang-way 发表于 2024-6-21 13:45
试试我这个 秒完成

感谢关注和回复  菜虫一个 高级语言看不懂 学不会啊

titi012

参与 一下。。。。

这个不使用Workbook.Open，而是用Adobd，速度会快很多，特别是读入很多个EXCEL表格的数据时差别就很明显了。

titi012

1. Sub Test1()
   
2.     Dim i&, j&, x&, Arr, Nrr(), Wk As Workbook
   
3.     Dim Conn, Reco1, Reco2, SQL$, Table
   
4.     Application.ScreenUpdating = False
   
5.     With Application.FileDialog(3) '
   
6.         .AllowMultiSelect = True '
   
7.         .Filters.Clear
   
8.         .Filters.Add "Excel File", "*.xls*"
   
9.         If .Show = -1 Then
   
10.             ReDim Nrr(1 To .SelectedItems.Count)
    
11.             For i = 1 To .SelectedItems.Count
    
12.                 Nrr(i) = .SelectedItems(i)
    
13.             Next i
    
14.         End If
    
15.     End With
    
16.     If i = 0 Then Exit Sub
    
17.     Set Wk = ThisWorkbook
    
18.     Set Conn = CreateObject("adodb.connection")
    
19.     Set Reco1 = CreateObject("adodb.recordset")
    
20.     Set Reco2 = CreateObject("adodb.recordset")
    
21.     x = 1
    
22.     For i = 1 To UBound(Nrr)
    
23.         Conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no;imex=1';Data Source = " & Nrr(i)
    
24.         Set Reco1 = Conn.OpenSchema(20)
    
25.         Do Until Reco1.EOF
    
26.             If Reco1.Fields("TABLE_TYPE") = "TABLE" Then
    
27.                 Table = Reco1("TABLE_NAME").Value
    
28.                 If Right(Table, 1) = "$" Or Right(Table, 2) = "$'" Then
    
29.                     Table = "[" & Table & "]"
    
30.                     SQL = "select * from " & Table
    
31.                     Reco2.Open SQL, Conn, 1, 1
    
32.                     Arr = Reco2.getrows
    
33.                     Wk.Sheets(1).Range("a" & x).Resize(UBound(Arr, 2), UBound(Arr)) = WorksheetFunction.Transpose(Arr)
    
34.                     x = x + UBound(Arr, 2)
    
35.                     Reco2.Close
    
36.                     Erase Arr
    
37.                 End If
    
38.             End If
    
39.             Reco1.MoveNext
    
40.         Loop
    
41.         Conn.Close
    
42.     Next i
    
43.     Application.ScreenUpdating = True
    
44. End Sub

复制代码

lizhipei78

赋值这一块其实占用的时间并不多，占用时间多的是打开工作簿及关闭工作簿这个

lizhipei78

数组嵌套读用Application.Rept(Arr, 1)这个就能读取

sero61

titi012 发表于 2024-6-21 17:06
参与 一下。。。。

这个不使用Workbook.Open，而是用Adobd，速度会快很多，特别是读入很多个EXCEL表格的 ...

感谢关注指点，能不能教一下那个嵌套数组的转换

sero61

lizhipei78 发表于 2024-6-21 17:20
赋值这一块其实占用的时间并不多，占用时间多的是打开工作簿及关闭工作簿这个

谢谢关注 搜得斯里，能不能教一下那个嵌套数组的转换

titi012

sero61 发表于 2024-6-21 17:56
感谢关注指点，能不能教一下那个嵌套数组的转换

前面的贴子漏了贴上代码，后面有补上的，不过还在审核中吧。