汇总的程序编写

whoami0001

工作需要，每周要填写回款预测以及后续一个季度，然后再汇总出来。


自己编写了一个，但感觉很笨的办法，有没有好的方法？

shiruiqiang

两张表差不多，用字典

LIUZHU

WPSJS宏

LIUZHU

附件在此，请用WPS测试

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim arr()
Set d = CreateObject("scripting.dictionary")
With Sheets("填写此表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
   y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < 7 Then MsgBox "填写此表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
k = 1: y = 1
arr(1, 1) = "月份"
For j = 4 To UBound(ar, 2) Step 2
    If Trim(ar(1, j)) <> "" Then
        t = d(Trim(ar(1, j)))
        If t = "" Then
            k = k + 1
            d(Trim(ar(1, j))) = k
            t = k
            arr(k, 1) = ar(1, j)
        End If
        For i = 3 To UBound(ar)
            If Trim(ar(i, j)) <> "" Then
                lh = d(Trim(ar(i, j)))
                If lh = "" Then
                    y = y + 1
                    d(Trim(ar(i, j))) = y
                    lh = y
                    arr(1, y) = ar(i, j)
                End If
                arr(t, lh) = arr(t, lh) + ar(i, j - 1)
            End If
        Next i
    End If
Next j
y = y + 1
arr(1, 1) = "合计"
For i = 2 To k
    hj = Application.Sum(Application.Index(arr, i, 0))
    arr(i, y) = hj
Next i
With Sheets("汇总")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
     .Range("b3:e" & rs) = Empty
    .[b3].Resize(k, y) = arr
End With
End Sub

3190496160

回款表格.rar (38.26 KB, 下载次数: 18)

2022-12-24 09:46 上传

点击文件名下载附件

准提部林

月汇总//
Sub TEST_M1()
Dim Arr, Brr(1 To 12, 1 To 3), i&, j%, M%, C%, V, T$
Arr = Sheet2.UsedRange.Value
For j = 3 To UBound(Arr, 2) Step 2
    M = Val(Arr(1, j))
    If M = 0 Or M > 12 Then GoTo j01
    For i = 3 To UBound(Arr)
        V = Val(Arr(i, j)): T = UCase(Arr(i, j + 1))
        C = Switch(T = "CASH", 1, T = "PN", 2, T = T, 0)
        If C = 0 Or V = 0 Then GoTo i01
        Brr(M, C) = Brr(M, C) + V
        Brr(M, 3) = Brr(M, 3) + V
i01: Next i
j01: Next j
Sheet4.[c4].Resize(12, 3) = Brr
End Sub

准提部林

公司汇总//
Sub TEST_P1()
Dim Arr, Brr(1 To 12, 1 To 3), i&, j%, P$, M%, C%, V, T$
Arr = Sheet2.UsedRange.Value
P = Sheet4.[g3]: If P = "" Then Exit Sub
For j = 3 To UBound(Arr, 2) Step 2
    M = Val(Arr(1, j))
    If M = 0 Or M > 12 Then GoTo j01
    For i = 3 To UBound(Arr)
        If Arr(i, 1) <> P Then GoTo i01
        V = Val(Arr(i, j)): T = UCase(Arr(i, j + 1))
        C = Switch(T = "CASH", 1, T = "PN", 2, T = T, 0)
        If C = 0 Or V = 0 Then GoTo i01
        Brr(M, C) = Brr(M, C) + V
        Brr(M, 3) = Brr(M, 3) + V
i01: Next i
j01: Next j
Sheet4.[h4].Resize(12, 3) = Brr
End Sub

Hontyu

            练习

破例

参与一下参与一下