汇总代码 类似于数据透视表

3190496160

Private Sub CommandButton1_Click()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim ar(), br()
ReDim ar(1 To Sheets.Count - 1)
With ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) = True Then
            n = n + 1
            ar(n) = .List(i, 0)
        End If
    Next i
End With
If n = "" Then MsgBox "请选择要汇总的对账单！": Exit Sub
ReDim br(1 To 100000, 1 To 13)
For s = 1 To n
    mc = ar(s)
    cr = Sheets(mc).[a1].CurrentRegion
    For i = 2 To UBound(cr)
        If cr(i, 2) <> "" Then
            t = d(cr(i, 2))
            If t = "" Then
                k = k + 1
                d(cr(i, 2)) = k
                t = k
                br(k, 1) = k
                br(k, 2) = cr(i, 2) & ""
                br(k, 3) = cr(i, 3)
                br(k, 5) = cr(i, 5)
                br(k, 7) = cr(i, 7)
                br(k, 9) = cr(i, 9)
                br(k, 11) = cr(i, 11)
            End If
            br(t, 4) = br(t, 4) + cr(i, 4)
            br(t, 6) = br(t, 6) + cr(i, 6)
            br(t, 8) = br(t, 8) + cr(i, 8)
            br(t, 10) = br(t, 10) + cr(i, 10)
            br(t, 12) = br(t, 12) + cr(i, 15)
            br(t, 13) = br(t, 13) + cr(i, 16)
        End If
    Next i
Next s
If k = "" Then MsgBox "没有需要汇总的数据！": Exit Sub
With Sheets("汇总")
    .[a1].CurrentRegion.Offset(1).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(k, UBound(br, 2)) = br
    .[a2].Resize(k, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub
Private Sub UserForm_Initialize()
Dim ar()
ReDim ar(1 To Sheets.Count - 1, 1 To 1)
For Each sh In Sheets
    If sh.Name <> ActiveSheet.Name Then
        n = n + 1
        ar(n, 1) = sh.Name
    End If
Next sh
With ListBox1
    .Clear
    .List = ar
End With
End Sub

3190496160

3.rar (88.44 KB, 下载次数: 14)

2024-8-14 11:26 上传

点击文件名下载附件

3190496160

结果未认真核对，仅供参考

kyxfyzg

试试看看这个可以不

Peny2020

参与一下子。

1013182120

3190496160 发表于 2024-8-14 11:26

老师的代码牛，达到了想要的结果。

blackttea1

学习啦 ，谢谢

1013182120

kyxfyzg 发表于 2024-8-14 12:06
试试看看这个可以不

谢谢指导，给您点赞。

1013182120

Peny2020 发表于 2024-8-14 12:32
参与一下子。

谢谢指导，给您点赞。