高手帮助 多个工作簿合并到一个工作簿

xiaodong112233

高手帮助 多个工作簿合并到一个工作簿
写个VBA代码


文件是xls的
每个工作簿后面6位数 从小到大排列
合并到vba合并簿中，显示AA AB AC AD AE 表 以此类推


有空行删除 并行调整一下


谢谢

ykcbf1100

汇总表中的表是需要根据文件名去新建的吗？还是那些表原来就已经有了？

xiaodong112233

ykcbf1100 发表于 2024-12-9 14:21
汇总表中的表是需要根据文件名去新建的吗？还是那些表原来就已经有了？

新建的 因为有时候多 有时候少

ykcbf1100

xiaodong112233 发表于 2024-12-9 14:24
新建的 因为有时候多 有时候少

那你用英文字母去表示表名，如果文件多了，怎么去写表名呢？

xiaodong112233

最多五百个 aa到zz 26*26=676个 够用了。

ykcbf1100

比较复杂
fso+正则+ArrayList
fso用于多文件查找，正则用于去除分表的不可见字符（主要用于标题行），ArrayList用于文件名排序

附件供参考。。。

ykcbf1100

多文件合并

1. Sub ykcbf()   '//2024.12.9
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set List = CreateObject("System.Collections.ArrayList")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Dim rng As Range
   
8.     Set ws = ThisWorkbook
   
9.     Set sh = ws.Sheets("Sheet1")
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then sht.Delete
    
12.     Next
    
13.     p = ThisWorkbook.Path & ""
    
14.     For Each f In fso.GetFolder(p).Files
    
15.         If LCase$(f.Name) Like "*[0-9_0-9]*" Then
    
16.             fn = Split(fso.GetBaseName(f), "_")
    
17.             fn = fn(1)
    
18.             List.Add fn
    
19.         End If
    
20.     Next f
    
21.     List.Sort
    
22.     For Each k In List
    
23.         n = n + 1
    
24.         Set sht = ws.Sheets.Add(After:=ws.Sheets(ws.Sheets.Count))
    
25.         sht.Name = "A" & CNtoW(n)
    
26.         ReDim brr(1 To 10000, 1 To 5)
    
27.         m = 0
    
28.         For Each f In fso.GetFolder(p).Files
    
29.             If LCase$(f.Name) Like "*[0-9_0-9]*" Then
    
30.                 fn = Split(fso.GetBaseName(f), "_")
    
31.                 If fn(1) = k Then
    
32.                     Set wb = Workbooks.Open(f, 0)
    
33.                     With wb.Sheets(1)
    
34.                         Set rng = .UsedRange
    
35.                         Call qc(rng)
    
36.                         arr = rng.Value
    
37.                     End With
    
38.                     wb.Close 0
    
39.                     For i = 3 To UBound(arr)
    
40.                         If arr(i, 2) <> Empty Then
    
41.                             m = m + 1
    
42.                             For j = 1 To UBound(arr, 2)
    
43.                                 brr(m, j) = arr(i, j)
    
44.                             Next
    
45.                         End If
    
46.                     Next
    
47.                     With sht
    
48.                         .[b1].Resize(, 3) = Split(arr(1, 1))
    
49.                         .Columns(1).NumberFormatLocal = "h:mm"
    
50.                         .[a2].Resize(m, 5) = brr
    
51.                     End With
    
52.                 End If
    
53.             End If
    
54.         Next f
    
55.     Next
    
56.     sh.Activate
    
57.     Set d = Nothing
    
58.     Application.ScreenUpdating = True
    
59.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
60. End Sub
    
61. 
    
62. Function qc(rng As Range)
    
63.     Set reg = CreateObject("VBScript.Regexp")
    
64.     With reg
    
65.         .Pattern = "[\s\x7F-\xA0]+"
    
66.         For Each rn In rng
    
67.             rn.Value = .Replace(rn.Value, "")
    
68.         Next
    
69.     End With
    
70. End Function
    
71. 
    
72. Function CNtoW(ByVal num As Long) As String
    
73.     CNtoW = Replace(Cells(1, num).Address(False, False), "1", "")
    
74. End Function
    

复制代码

xiaodong112233

ykcbf1100 发表于 2024-12-9 15:31
比较复杂
fso+正则+ArrayList

多谢高手帮助 晚上试试

xiaodong112233

ykcbf1100 发表于 2024-12-9 15:31
比较复杂
fso+正则+ArrayList
fso用于多文件查找，正则用于去除分表的不可见字符（主要用于标题行），Arr ...

时间显示不对

ykcbf1100

xiaodong112233 发表于 2024-12-9 16:04
时间显示不对

改一下，修正时间