拆分工作表需求，求大侠帮忙在线等，急用

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr()
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim d As Object
   
7.   Dim rng As Range
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   For Each ws In Worksheets
    
12.     If Left(ws.Name, 1) Like "[A-D]" Then
    
13.       With ws
    
14.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
15.         arr = .Range("b1:b" & r)
    
16.         m = 0
    
17.         For i = 1 To UBound(arr)
    
18.           If arr(i, 1) = "分行" Then
    
19.             m = m + 1
    
20.             r1 = .Cells(i, 2).MergeArea.Rows.Count + i
    
21.             c = .Rows(i & ":" & r1 - 1).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    
22.             ReDim Preserve brr(1 To 4, 1 To m)
    
23.             brr(1, m) = i
    
24.             brr(2, m) = r1
    
25.             brr(3, m) = 0
    
26.             brr(4, m) = c
    
27.           End If
    
28.         Next
    
29.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
30.         For i = 1 To UBound(brr)
    
31.           For j = 1 To UBound(brr, 2)
    
32.             crr(j, i) = brr(i, j)
    
33.           Next
    
34.         Next
    
35.         
    
36.         For i = 1 To UBound(crr) - 1
    
37.           crr(i, 3) = crr(i + 1, 1) - 2
    
38.         Next
    
39.         crr(UBound(crr), 3) = r
    
40.         
    
41.         For q = 1 To UBound(crr)
    
42.           For i = crr(q, 2) To crr(q, 3)
    
43.             If Not d.exists(arr(i, 1)) Then
    
44.               Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
45.             End If
    
46.             If Not d(arr(i, 1)).exists(ws.Name) Then
    
47.               Set d(arr(i, 1))(ws.Name) = CreateObject("scripting.dictionary")
    
48.             End If
    
49.             If Not d(arr(i, 1))(ws.Name).exists(q) Then
    
50.               Set d(arr(i, 1))(ws.Name)(q) = .Cells(crr(q, 1) - 1, 2).Resize(crr(q, 2) - crr(q, 1) + 1, crr(q, 4) - 1)
    
51.             End If
    
52.             Set d(arr(i, 1))(ws.Name)(q) = Union(d(arr(i, 1))(ws.Name)(q), .Cells(i, 2).Resize(1, crr(q, 4) - 1))
    
53.           Next
    
54.         Next
    
55.       End With
    
56.     End If
    
57.   Next
    
58.   For Each aa In d.keys
    
59.     Application.SheetsInNewWorkbook = d(aa).Count
    
60.     Set wb = Workbooks.Add
    
61.     With wb
    
62.       m = 1
    
63.       For Each bb In d(aa).keys
    
64.         With Worksheets(m)
    
65.           .Name = bb
    
66.           For Each cc In d(aa)(bb).keys
    
67.             r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
68.             If r > 1 Then
    
69.               r = r + 2
    
70.             End If
    
71.             d(aa)(bb)(cc).Copy .Cells(r, 2)
    
72.           Next
    
73.         End With
    
74.         m = m + 1
    
75.       Next
    
76.       ThisWorkbook.Worksheets("目录及报表说明").Copy before:=.Worksheets(1)
    
77.       .SaveAs Filename:=ThisWorkbook.Path & "" & "财务数据_" & aa & ".xls"
    
78.       .Close False
    
79.     End With
    
80.   Next
    
81.   Application.SheetsInNewWorkbook = 3
    
82. End Sub
    

复制代码

chxw68

问题全部解决了。要求表格格式必须规范，每张表格都从第2列开始，而且每张表头都有“分行”二字，对每张工作表里有多少张表格没有限制，就像A表一样，有2张、3张、4张等都可以。

坏也是一种态度

chxw68 发表于 2015-10-28 16:10
问题全部解决了。要求表格格式必须规范，每张表格都从第2列开始，而且每张表头都有“分行”二字，对每张工 ...

真是太感谢了，解决大问题了

huazai688

chxw68 发表于 2015-10-28 16:10
问题全部解决了。要求表格格式必须规范，每张表格都从第2列开始，而且每张表头都有“分行”二字，对每张工 ...

格式不同多工作表拆分生成新工作簿.rar (91.41 KB, 下载次数: 4)

2015-12-9 09:55 上传

点击文件名下载附件

老师您好！我也有类似分表需要，麻烦您帮忙看下应如何通过VBA实现，谢谢！