求助，读取名字，并汇总金额

卡拉不ok

1、提取出底表，蓝色列，不重复的姓名，并放到汇总表的位置，通过对应的日期，汇总求和。
2、底表的名称列会持续增加，也要实现有增加还是依然读取不重复姓名，姓名列的位置都是固定的。
3，需要用vba实现，感谢大佬。

Yalishanda30

这种表在设计之初就应该考虑到需要汇总的问题

蓝桥玄霜

汇总的例子：

卡拉不ok

蓝桥玄霜 发表于 2023-4-16 21:22
汇总的例子：

大佬，能给个码不

jjmysjg

蓝桥玄霜 发表于 2023-4-16 21:22
汇总的例子：

1、d1没有定义；
2、d1(y) = "" 类型不匹配
麻烦老师看看

蓝桥玄霜

jjmysjg 发表于 2023-4-17 07:02
1、d1没有定义；
2、d1(y) = "" 类型不匹配
麻烦老师看看

是不是漏抄了一句：Set d1 = CreateObject("Scripting.Dictionary")

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("底表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r < 6 Or y < 5 Then MsgBox "底表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
br(1, 1) = "兼职": br(1, 2) = "合计"
k = 2: m = 2
For i = 6 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        If IsDate(ar(i, 1)) Then
            t = d(Trim(ar(i, 1)))
            If t = "" Then
                k = k + 1
                d(Trim(ar(i, 1))) = k
                t = k
                br(k, 1) = ar(i, 1)
            End If
            For j = 5 To y Step 4
                If Trim(ar(2, j)) = "兼职" Then
                    If Trim(ar(i, j)) <> "" Then
                        lh = d(Trim(ar(i, j)))
                        If lh = "" Then
                            m = m + 1
                            d(Trim(ar(i, j))) = m
                            lh = m
                            br(1, m) = ar(i, j)
                        End If
                        br(t, lh) = br(t, lh) + ar(i, j + 3)
                    End If
                End If
            Next j
        End If
    End If
Next i
With Sheets("汇总表")
    .UsedRange = Empty
    .[a2].Resize(k, m) = br
    For i = 3 To k + 1
        .Cells(i, 2).FormulaR1C1 = "=SUM(RC[1]:RC[" & m - 2 & "])"
    Next i
    For j = 3 To m
        .Cells(3, j).FormulaR1C1 = "=SUM(R[1]C:R[" & k - 2 & "]C)"
    Next j
End With
MsgBox "ok!"
End Sub

3190496160

记录表.rar (34.57 KB, 下载次数: 9)

2023-4-17 11:16 上传

点击文件名下载附件

jjmysjg

蓝桥玄霜 发表于 2023-4-17 09:01
是不是漏抄了一句：Set d1 = CreateObject("Scripting.Dictionary")

谢谢老师！d1写成dl了