关于总表按即定格式拆分的

aifeiqi

请老师们看看这个怎么拆分，之前做过合并的：

  1、根据汇总表按模板拆分到相关分表，附件里的各分表是我要生成的，每个分表上年结存数据来源于客户起初数；
  2、每个分表记得要有每月合计数，最后一行本月合计数，本年累计数
  3、按汇总表里P列客户简称拆分

ykcbf1100

这个有点烦，要写的代码比较多，先看看。

3190496160

Sub 按客户拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 3 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
With Sheets("客户期初")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    cr = .Range("a4:f" & rs)
End With
For i = 2 To UBound(cr)
    If Trim(cr(i, 2)) <> "" Then
        dc(Trim(cr(i, 2))) = i
    End If
Next i

With Sheets("汇总表")
    r = .Cells(Rows.Count, 16).End(xlUp).Row
    y = .Cells(4, Columns.Count).End(xlToLeft).Column
    If r < 7 Then MsgBox "汇总表为空！": End
    ar = .Range(.Cells(5, 1), .Cells(r, 16))
End With
For i = 3 To UBound(ar)
    If Trim(ar(i, 16)) <> "" Then
        d(Trim(ar(i, 16))) = ""
    End If
Next i
For Each k In d.keys
    n = 0: dic.RemoveAll
    ReDim br(1 To UBound(ar), 1 To 12)
    n = 1
    br(n, 5) = "上年结存"
    xh = dc(k)
    br(n, 12) = cr(xh, 6)
    For i = 3 To UBound(ar)
        If Trim(ar(i, 16)) = k Then
            n = n + 1
            zd = Format(ar(i, 1), "yyyym")
            dic(zd) = ""
            br(n, 1) = ar(i, 1)
            For j = 4 To 11
                br(n, j) = ar(i, j)
            Next j
            br(n, 12) = br(n - 1, 12) + br(n, 10) + br(n, 11)
        End If
    Next i
    Sheets("模板").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = k
        xh = dc(k)
        If xh <> "" Then
            .[d4] = cr(xh, 1)
            .[l7] = cr(xh, 6)
        End If
        For Each kc In dic.keys
            m = 0
            ReDim brr(1 To n, 1 To 12)
            For i = 2 To n
                zd = Format(br(i, 1), "yyyym")
                If zd = kc Then
                    m = m + 1
                    For j = 1 To UBound(br, 2)
                        brr(m, j) = br(i, j)
                    Next j
                End If
            Next i
            .[a7].Resize(1, UBound(br, 2)) = br
            ws = .Cells(Rows.Count, 5).End(xlUp).Row + 1
            .Cells(ws, 1).Resize(m, UBound(brr, 2)) = brr
            .Cells(ws + m, 5) = "本月合计"
            .Cells(ws + m, 8) = Application.Sum(.Range("h" & ws & ":h" & ws + m - 1))
            .Cells(ws + m, 10) = Application.Sum(.Range("j" & ws & ":j" & ws + m - 1))
            .Cells(ws + m, 11) = Application.Sum(.Range("k" & ws & ":k" & ws + m - 1))
            .Cells(ws + m, 12) = .Cells(ws + m - 1, 12)
        Next kc
    End With
Next k
Set d = Nothing
Set dc = Nothing
Set dic = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

应收账款总览.rar (130.67 KB, 下载次数: 17)

2023-4-27 15:04 上传

点击文件名下载附件

3190496160

一个初稿，很多细节还没有考虑，仅供参考

likaiyihou

要写的代码太多了，写了一半没精力了，抱歉

aifeiqi

3190496160 发表于 2023-4-27 15:04

老师，谢谢你的多次出手，经测试基本可以，
1、差最下面一行本年累计没生成，基本能用了；
2、各个分表客户代码和客户名称没有生成。

chxw68

1. Sub test()
   
2.     Dim r%, i%, m%
   
3.     Dim arr, brr, crr(1 To 2, 1 To 14)
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("客户期初")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         arr = .Range("a5:f" & r)
   
10.         For i = 1 To UBound(arr)
    
11.             d1(arr(i, 2)) = Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
    
12.         Next
    
13.     End With
    
14.     With Worksheets("汇总表")
    
15.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.         arr = .Range("a7:p" & r)
    
17.     End With
    
18.     For i = 1 To UBound(arr)
    
19.         yf = Month(arr(i, 1))
    
20.         If Not d.exists(arr(i, 16)) Then
    
21.             Set d(arr(i, 16)) = CreateObject("scripting.dictionary")
    
22.         End If
    
23.         If Not d(arr(i, 16)).exists(yf) Then
    
24.             Set d(arr(i, 16))(yf) = CreateObject("scripting.dictionary")
    
25.         End If
    
26.         d(arr(i, 16))(yf)(i) = Empty
    
27.     Next
    
28.     For Each aa In d.keys
    
29.         s = 1
    
30.         For Each bb In d(aa).keys
    
31.             s = s + d(aa)(bb).Count + 1
    
32.         Next
    
33.         s = s + 1
    
34.         ReDim brr(1 To s, 1 To 14)
    
35.         brr(1, 5) = "上年结存"
    
36.         If d1.exists(aa) Then
    
37.             brr(1, 12) = d1(aa)(4)
    
38.         End If
    
39.         m = 1
    
40.         crr(1, 5) = "本月合计"
    
41.         crr(2, 5) = "本年累计"
    
42.         For Each bb In d(aa).keys
    
43.             For Each cc In d(aa)(bb).keys
    
44.                 m = m + 1
    
45.                 For j = 1 To UBound(brr, 2)
    
46.                     brr(m, j) = arr(bb, j)
    
47.                 Next
    
48.                 brr(m, 12) = brr(m - 1, 12) + brr(m, 10) - brr(m, 11)
    
49.                 For Each y In Array(8, 10, 11)
    
50.                     crr(1, y) = crr(1, y) + brr(m, y)
    
51.                     crr(2, y) = crr(2, y) + brr(m, y)
    
52.                 Next
    
53.             Next
    
54.             m = m + 1
    
55.             For j = 1 To UBound(crr, 2)
    
56.                 brr(m, j) = crr(1, j)
    
57.             Next
    
58.             brr(m, 12) = brr(m - 1, 12)
    
59.             For Each y In Array(8, 10, 11)
    
60.                 crr(1, y) = Empty
    
61.             Next
    
62.         Next
    
63.         m = m + 1
    
64.         For j = 1 To UBound(crr, 2)
    
65.             brr(m, j) = crr(2, j)
    
66.         Next
    
67.         For Each y In Array(8, 10, 11)
    
68.             crr(2, y) = Empty
    
69.         Next
    
70.         brr(m, 12) = brr(m - 1, 12)
    
71.         With Worksheets("模板")
    
72.             .Range("d4") = d1(aa)(0)
    
73.             .Range("e4") = aa
    
74.             .Range("h4") = d1(aa)(1)
    
75.             .Range("j4") = d1(aa)(2)
    
76.             .Range("l4") = d1(aa)(3)
    
77.             r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
78.             If r > 7 Then
    
79.                 .Rows("7:" & r - 1).Delete
    
80.             End If
    
81.             .Rows(7).Resize(UBound(brr)).Insert
    
82.             With .Range("a7").Resize(UBound(brr), UBound(brr, 2))
    
83.                 .Value = brr
    
84.                 .Borders.LineStyle = xlContinuous
    
85.                 .Interior.ColorIndex = xlNone
    
86.                 With .Font
    
87.                     .ColorIndex = 0
    
88.                     .Bold = False
    
89.                 End With
    
90.             End With
    
91.             For i = 1 To UBound(brr)
    
92.                 If brr(i, 5) = "本月合计" Or brr(i, 5) = "本年累计" Then
    
93.                     With .Cells(i + 6, 1).Resize(1, 14).Borders(xlEdgeLeft)
    
94.                         .LineStyle = xlContinuous
    
95.                         .ColorIndex = 3
    
96.                     End With
    
97.                     With .Cells(i + 6, 1).Resize(1, 14).Borders(xlEdgeTop)
    
98.                         .LineStyle = xlContinuous
    
99.                         .ColorIndex = 3
    
100.                     End With
     
101.                     With .Cells(i + 6, 1).Resize(1, 14).Borders(xlEdgeBottom)
     
102.                         .LineStyle = xlContinuous
     
103.                         .ColorIndex = 3
     
104.                     End With
     
105.                     With .Cells(i + 6, 1).Resize(1, 14).Borders(xlEdgeRight)
     
106.                         .LineStyle = xlContinuous
     
107.                         .ColorIndex = 3
     
108.                     End With
     
109.                 End If
     
110.             Next
     
111.             r = .Cells(.Rows.Count, 4).End(xlUp).Row
     
112.             With .Cells(r, 1).Resize(1, 14)
     
113.                 With .Borders(xlEdgeTop)
     
114.                     .LineStyle = xlContinuous
     
115.                     .Color = -1003520
     
116.                     .TintAndShade = 0
     
117.                     .Weight = xlThick
     
118.                 End With
     
119.             End With
     
120.             .Copy after:=Worksheets(Worksheets.Count)
     
121.             On Error Resume Next
     
122.             Worksheets(aa).Delete
     
123.             On Error GoTo 0
     
124.             ActiveSheet.Name = aa
     
125.         End With
     
126.     Next
     
127. End Sub
     

复制代码

chxw68

参与一下。

chxw68

按楼主的要求完善了一下格式。