按照标题字段汇集所选定文件件里的所有工作簿

shiruiqiang

wowo000 发表于 2024-4-6 10:03
尊敬的baofa2老师和shiruiqiang老师及ykcbf1100老师：假如“汇集表”第一行的标题字段用VBA代码自动生成咋 ...

不用就行

baofa2

wowo000 发表于 2024-4-6 10:03
尊敬的baofa2老师和shiruiqiang老师及ykcbf1100老师：假如“汇集表”第一行的标题字段用VBA代码自动生成咋 ...

我的写法，你删除就行了，自动生成

jjmysjg

ykcbf1100 发表于 2024-4-6 10:01
再加个表循环

提取夹内各簿各表的第一行不重复字段到汇总表的第一行，相应数据合并到汇总表。
期待。

ooluckydog

ykcbf1100

jjmysjg 发表于 2024-4-6 10:55
提取夹内各簿各表的第一行不重复字段到汇总表的第一行，相应数据合并到汇总表。
期待。

现在的代码加个多表循环就可以了。

jjmysjg

ooluckydog 发表于 2024-4-6 10:56

这是合并各簿的第1个工作表。
要合并各簿的所有表，怎么修改？
谢谢！

ykcbf1100

wowo000 发表于 2024-4-6 10:03
尊敬的baofa2老师和shiruiqiang老师及ykcbf1100老师：假如“汇集表”第一行的标题字段用VBA代码自动生成咋 ...

更简单了，代码更少。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.6
   
2.     Application.ScreenUpdating = False
   
3.     Application.AskToUpdateLinks = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Set sh = ThisWorkbook.Sheets("汇集表")
   
9.     ReDim brr(1 To 10000, 1 To 100)
   
10.     With Application.FileDialog(msoFileDialogFolderPicker)
    
11.         .Title = "请选择文件夹"
    
12.         .InitialFileName = ThisWorkbook.Path & ""
    
13.         If .Show = -1 Then
    
14.             p = .SelectedItems(1) & ""
    
15.         End If
    
16.     End With
    
17.     For Each f In fso.GetFolder(p).Files
    
18.         If f.Name Like "*.xls*" Then
    
19.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
20.                 fn = fso.GetBaseName(f)
    
21.                 Set wb = Workbooks.Open(f, 0)
    
22.                 With wb.Sheets(1)
    
23.                     .AutoFilterMode = False
    
24.                     arr = .UsedRange
    
25.                     wb.Close False
    
26.                 End With
    
27.                 For i = 2 To UBound(arr)
    
28.                     If arr(i, 1) <> Empty Then
    
29.                         m = m + 1
    
30.                         For j = 1 To UBound(arr, 2)
    
31.                             s = arr(1, j)
    
32.                             If s <> Empty Then
    
33.                                 If Not d.exists(s) Then
    
34.                                     n = n + 1
    
35.                                     d(s) = n
    
36.                                 End If
    
37.                                 brr(m, d(s)) = arr(i, j)
    
38.                             End If
    
39.                         Next
    
40.                     End If
    
41.                 Next
    
42.             End If
    
43.         End If
    
44.     Next f
    
45.     With sh
    
46.         .UsedRange.Clear
    
47.         .[a1].Resize(1, d.Count) = d.keys
    
48.         .[a1].Resize(1, d.Count).Interior.Color = 49407
    
49.         If m Then
    
50.             .[a2].Resize(m, d.Count) = brr
    
51.             .Range("A1").Resize(m + 1, d.Count).Borders.LineStyle = 1
    
52.         End If
    
53.     End With
    
54.     Set d = Nothing
    
55.     Application.ScreenUpdating = True
    
56.     Application.AskToUpdateLinks = True
    
57.     Application.DisplayAlerts = True
    
58.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
59. End Sub
    
60. 
    

复制代码

ykcbf1100

jjmysjg 发表于 2024-4-6 10:55
提取夹内各簿各表的第一行不重复字段到汇总表的第一行，相应数据合并到汇总表。
期待。

见１７楼代码。。

jjmysjg

ykcbf1100 发表于 2024-4-6 11:07
更简单了，代码更少。

增加一个功能：各簿的所有表合并进去(这个是合并第1个表的)