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

aifeiqi

chxw68 发表于 2023-4-28 09:52
按楼主的要求完善了一下格式。

老师，我在汇总表里增加了一些数据和公司(标红部分)，经测试不行了，实际应用中有好几百客户

chxw68

修改好了。出问题的原因是初始数据里没有些单位的数据。

aifeiqi

chxw68 发表于 2023-4-28 11:09
修改好了。出问题的原因是初始数据里没有些单位的数据。

老师，新加的那三行，生成的shdf工作表里的日期不对，这个数据好像就是模板数据。

chxw68

修改好了。

准提部林

日期有2020/2023 ????

chxw68

准提部林 发表于 2023-4-28 14:51
日期有2020/2023 ????

呵呵，没有细看，代码处理的时候只考虑了月份，没有考虑年份。

xzlu13014

chxw68 发表于 2023-4-28 09:02
参与一下。

高手啊，我就不会写代码 太厉害了

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
        .[e4] = k
        xh = dc(k)
        If xh <> "" Then
            .[d4] = cr(xh, 1)
            .[h4] = cr(xh, 3)
            .[l4] = cr(xh, 5)
            .[j4] = cr(xh, 4)
            .[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)
            .Rows(ws + m).Font.ColorIndex = 3
        Next kc
        ws = .Cells(Rows.Count, 5).End(xlUp).Row + 1
        .Cells(ws, 5) = "本年合计"
        .Rows(ws).Font.ColorIndex = 3
        rr = Array(8, 10, 11, 12)
        For s = 0 To UBound(rr)
            hj = 0
            lh = rr(s)
            For i = 3 To ws - 1
                If Trim(.Cells(i, 5)) = "本月小计" Then
                    hj = hj + .Cells(i, lh)
                End If
            Next i
            .Cells(ws, lh) = hj
        Next s
        If ws + 1 <= 91 Then .Rows(ws + 1 & ":91").Delete
    End With
Next k
Set d = Nothing
Set dc = Nothing
Set dic = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

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

2023-4-28 17:15 上传

点击文件名下载附件

aifeiqi

3190496160 发表于 2023-4-28 17:15

老师，1、本年累计没有生年数据，图1
2、另外本年数据以下边框不要了，如图2