根据表头，保留格式合并多个工作簿为一个工作表

mohao

现在大部例子都是每个工作簿表头相同合并，现在想根据表头，保留格式合并多个工作簿为一个工作表

shiruiqiang

====选择文件夹，好用送花====

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.4
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     p = ThisWorkbook.Path & ""
   
8.     p1 = p & "Mh"
   
9.     f = p1 & "合并表.xlsx"
   
10.     Set ws = Workbooks.Open(f, 0)
    
11.     Set sh = ws.Sheets("合并表")
    
12.     On Error Resume Next
    
13.     For Each f In Fso.GetFolder(p1).Files
    
14.         If f.Name Like "*.xls*" Then
    
15.             If InStr(f.Name, "合并表") = 0 Then
    
16.                 fn = Fso.GetBaseName(f)
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 With wb.Sheets(1)
    
19.                     arr = .UsedRange
    
20.                     wb.Close False
    
21.                 End With
    
22.                 For j = 1 To UBound(arr, 2)
    
23.                     If arr(i, 1) <> Empty Then
    
24.                         s = arr(1, j)
    
25.                         d1(s) = s
    
26.                     End If
    
27.                 Next
    
28.                 For i = 2 To UBound(arr)
    
29.                     s = arr(i, 1)
    
30.                     If s <> Empty Then
    
31.                         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
32.                         For j = 1 To UBound(arr, 2)
    
33.                             ss = arr(1, j)
    
34.                             d(s)(ss) = d(s)(ss) + arr(i, j)
    
35.                         Next
    
36.                     End If
    
37.                 Next
    
38.             End If
    
39.         End If
    
40.     Next
    
41.     ReDim zrr(1 To d.Count, 1 To 1)
    
42.     For Each k In d.keys
    
43.         n = n + 1
    
44.         zrr(n, 1) = k
    
45.     Next
    
46.     With sh
    
47.         .UsedRange = ""
    
48.         .[a1].Resize(1, d1.Count) = d1.keys
    
49.         .[a2].Resize(n, 1) = zrr
    
50.         arr = .UsedRange
    
51.         For i = 2 To UBound(arr)
    
52.             If arr(i, 1) <> Empty Then
    
53.                 For j = 2 To UBound(arr, 1)
    
54.                     If d.exists(arr(i, 1)) Then
    
55.                         arr(i, j) = d(arr(i, 1))(arr(1, j))
    
56.                     End If
    
57.                 Next
    
58.             End If
    
59.         Next
    
60.         .UsedRange = arr
    
61.         With .UsedRange
    
62.             .Value = arr
    
63.             .Borders.LineStyle = 1
    
64.             .HorizontalAlignment = xlCenter
    
65.             .VerticalAlignment = xlCenter
    
66.         End With
    
67.         ActiveWindow.DisplayZeros = False
    
68.     End With
    
69.     ws.Close 1
    
70.     Application.ScreenUpdating = True
    
71.     MsgBox "OK！"
    
72. End Sub
    
73. 
    

复制代码

ykcbf1100

附件供参考。。。

mohao

ykcbf1100 发表于 2024-1-4 18:23
附件供参考。。。

如果其中的工作簿有变动，合并的时候数据还是会出错

ykcbf1100

mohao 发表于 2024-1-4 20:18
如果其中的工作簿有变动，合并的时候数据还是会出错

代码肯定是根据附件来写的，你有变动，要看你怎么变了，代码并不完全是通用的。
你参考一下吧，我也不想改了。

mohao

shiruiqiang 发表于 2024-1-4 18:03
====选择文件夹，好用送花====

temp = Array("房间", "项目名称", "房屋性质", "应收房租", "应收场地租金", "实收房租", "实收场地租金")
代码能不能不要固定的？能自动读取每个工作簿的表头吗？

shiruiqiang

mohao 发表于 2024-1-4 20:30
temp = Array("房间", "项目名称", "房屋性质", "应收房租", "应收场地租金", "实收房租", "实收场地租金 ...

可以，双字典+字典嵌套

zpy2

//select * from consolidateSheet limit 20;
cli_one_dim_c~consolidateSheet~4;
create temp table aa as
select * from consolidateSheetUnion;
select * from aa limit 20;
cli_create_two_dim_no_order~aa~属性~数量;
select  colIndex[2:] from aa_two_dim;

https://m.bilibili.com/video/BV1R94y1P7o9?buvid=XUCA2D8C3A3798123A1B1C127292E7200B6A0&from_spmid=default-value&is_story_h5=false&mid=FSMZLyVVbtrPTKay0%2Fc9Fg%3D%3D&p=1&plat_id=116&share_fr