多薄多表合并(不限表头位置和顺序)

wtu37

还有一个：拆分后各表的列宽最好是和总表保持一致。

liuxi001

wtu37 发表于 2019-8-12 12:49
还有一个：拆分后各表的列宽最好是和总表保持一致。

只加了边框，其它格式没有处理

乾坤若木

学习了，谢谢分享。

乾坤若木

谢谢分享，楼主辛苦了。

wsq0317

好东西必须顶

恋人青文

广告SKU   7天内广告SKU销售量(#)
这种后面是包含前面字段名字的
数据会被前面“广告SKU”覆盖的情况要怎么解决呢~
看了蛮久代码不知道怎么解决

liuxi001

恋人青文 发表于 2019-12-17 16:52
广告SKU   7天内广告SKU销售量(#)
这种后面是包含前面字段名字的
数据会被前面“广告SKU”覆盖的情况要怎 ...

                                                '分表如果有重复表头或有近似的表头，将取第一个。如总表表头是”客户“，
                                                '分表中第2列是”客户姓名“，第3列是”姓名“，则取”客户姓名“列的数据。
                                                If z_to_fcol(i) = 0 And InStr(Trim(z_Title(1, i)), Trim(f_Tab(1, j))) > 0 Then

以上这句中InStr(Trim(z_Title(1, i)), Trim(f_Tab(1, j))) > 0是模糊匹配，你改为精确匹配即可，如此句改为：If z_to_fcol(i) = 0 And Trim(z_Title(1, i))=Trim(f_Tab(1, j)) Then

liuxi001

wtu37 发表于 2019-8-12 12:49
还有一个：拆分后各表的列宽最好是和总表保持一致。

类似这样，自己修改吧。

1. Sub test()
   
2.     With Sheet1
   
3.         c = .Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious, False, False, False).Column
   
4.         r = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row
   
5.         ReDim Height_Array(1 To r)
   
6.         ReDim Width_Array(1 To c)
   
7.         '获取总表列宽 行高
   
8.         For hang = 1 To UBound(Height_Array)
   
9.             Height_Array(hang) = .rows(hang).RowHeight
   
10.         Next
    
11.         For lie = 1 To UBound(Width_Array)
    
12.             Width_Array(lie) = .columns(lie).ColumnWidth
    
13.         Next
    
14.     End With
    
15.     '建新表
    
16.     '文件复制等
    
17.    
    
18.     '将获取的行高列宽应用到新表
    
19.     Call WidthSetup(Width_Array, ActiveSheet)
    
20.     Call HeightSetup(Height_Array, ActiveSheet)
    
21. End Sub
    
22. 
    
23. 
    
24. Sub WidthSetup(Width_Array, sh, Optional startCol = 1) '设置列宽
    
25.     For i = LBound(Width_Array) To UBound(Width_Array)
    
26.         MyLie = MyLie + 1
    
27.         sh.columns(startCol + MyLie - 1).ColumnWidth = Width_Array(i)
    
28.     Next
    
29. End Sub
    
30. Sub HeightSetup(Height_Array, sh, Optional startRow = 1) '设置行高
    
31.     For j = LBound(Height_Array) To UBound(Height_Array)
    
32.         MyHang = MyHang + 1
    
33.         sh.rows(startRow + MyHang - 1).RowHeight = Height_Array(j)
    
34.     Next
    
35. End Sub

复制代码

另附一个拆分代码，里面进行了列宽设置

1. Sub 一表拆成多簿()
   
2.     Dim arr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Application.EnableEvents = False
   
6.     zb = ActiveSheet.Name '总表
   
7.     Na = ActiveWorkbook.Name
   
8.     Na = Left(Na, InStrRev(Na, ".") - 1)
   
9.     p = ActiveWorkbook.Path & ""
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     '表头行数列数
    
12.     hl = InputBox("请输入表头行数和按哪几列拆分，并用逗号隔开,如：1,4,5表示表头有1行、按第4列和第5列进行拆分……", "输入", "1,4,5")
    
13.     If hl = "" Then GoTo errhybccdb
    
14.     t = Timer
    
15.     '新建文件夹'在本工作簿目录下，以本工作簿命名
    
16.     If Dir(p & Na, vbDirectory) = "" Then
    
17.         MkDir p & Na
    
18.     End If
    
19.     hl = Replace(hl, "，", ",")
    
20.     ro = Val(Split(hl, ",")(0))  '表头行数
    
21.     tjs = Split(hl, ",") '拆分条件
    
22.     With Sheets(zb) '总表
    
23.         col = .Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious, False, False, False).Column
    
24.         lastr = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False).Row '总表行号和列号
    
25.         arr = .[a1].Resize(lastr, col)
    
26.         ReDim Width_Array(1 To col)
    
27.         For y = 1 To UBound(Width_Array)
    
28.             Width_Array(y) = .columns(y).ColumnWidth '总表列宽
    
29.         Next
    
30.         For i = ro + 1 To UBound(arr)
    
31.             tj = ""
    
32.             If UBound(tjs) = 0 Then
    
33.                 MsgBox "请输入拆分条件列！"
    
34.             ElseIf UBound(tjs) = 1 Then
    
35.                 tj = arr(i, tjs(1))
    
36.             Else
    
37.                 For oo = 1 To UBound(tjs)
    
38.                     tj = tj & arr(i, tjs(oo))
    
39.                 Next
    
40.             End If
    
41.             If Not d.exists(tj) Then
    
42.                 Set d(tj) = .Cells(1, 1).Resize(ro, col)
    
43.             End If
    
44.             Set d(tj) = Union(d(tj), .Cells(i, 1).Resize(1, col))
    
45.         Next
    
46.     End With
    
47.     '为字典中每个KEY建工作簿
    
48.     For Each aa In d.keys
    
49.         Set wb = Workbooks.Add
    
50.         Set sh = wb.Worksheets(1)
    
51.         With sh
    
52.             d(aa).Copy .Range("a1")
    
53. '            .Columns.AutoFit '自动列宽
    
54.             aa = CLFFZF(aa) '判断文件名是否合法
    
55.             .Name = aa  '工作表名
    
56.             Call WidthSetup(Width_Array, sh)
    
57.         End With
    
58.         '保存并命名 工作簿名
    
59.         wb.SaveAs p & Na & "" & aa & ".xlsx"
    
60.         wb.Close
    
61.     Next
    
62.     MsgBox Format(Timer - t, "已完成，共耗时0.00秒"), vbInformation, "提示"
    
63.     tt = p & Na
    
64.     Shell "explorer.exe " & [tt], vbNormalFocus
    
65. errhybccdb:
    
66.     Application.ScreenUpdating = True
    
67.     Application.DisplayAlerts = True
    
68.     Application.EnableEvents = True
    
69. End Sub
    
70. Private Function CLFFZF(str)     '处理文件名中的非法字符
    
71.     ffzfs = "/,\,<,>,*,?,:,"",|" '文件名非法字符集
    
72.     ffzfs = Split(Replace(ffzfs, "，", ","), ",")
    
73.     For Each ff In ffzfs
    
74.         If Len(str) = 0 Then
    
75.             str = ""
    
76.         ElseIf InStr(str, ff) Then
    
77.             str = Replace(str, ff, "-")
    
78.         End If
    
79.     Next ff
    
80.     CLFFZF = str
    
81. End Function

复制代码

恋人青文

liuxi001 发表于 2019-12-17 18:10
'分表如果有重复表头或有近似的表头，将取第一个。如 ...

感谢感谢楼主 没想到这么快就收到你的回复

huazai688

好东西必须顶