如何用VBA实现一次性多列数据分类汇总，类似单列数据透视表

掘掘

Sub 最快法() '//By掘掘,郑广学的学生
    Dim dic As Object, key As String, dickeys, Item, dicItems
    Set dic = CreateObject("scripting.dictionary")
    Set dic列 = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion
    ReDim brr(1 To 10000, 1 To 50)
    brr(1, 1) = "单位"
    For j = 2 To UBound(arr, 2)
        For i = 2 To UBound(arr, 1)
            key = arr(i, 1) & ""
            If Not dic.Exists(key) Then
                行号 = dic.Count + 3 '
                dic(key) = 行号 '//记录行号
                brr(行号, 1) = arr(i, 1)
            End If
            行号 = dic(key) '//取出行号
            key = arr(i, j)
            If Not dic列.Exists(key) Then
                列号 = dic列.Count + 2 '//从第3行开始输出
                dic列(key) = 列号 '//记录行号
                brr(1, 列号) = arr(1, j)
                brr(2, 列号) = key
            End If
            列号 = dic列(key) '//取出列号
            brr(行号, 列号) = brr(行号, 列号) + 1
        Next
    Next
    For j = 2 To dic列.Count + 1 '//从列开始,下标法最大列号+1列单位为总列数
        For i = 3 To 行号 '两行是标题,从第三行开始合计
            brr(行号 + 1, j) = brr(行号 + 1, j) + brr(i, j)
        Next
    Next
    brr(行号 + 1, 1) = "合计"
    Sheet1.Range("h1").Resize(行号 + 1, UBound(brr, 2)) = brr: Sheet1.Range("h1").Resize(2, 1).Merge
    横向合并拆分相容单元格 Sheet1.Range("h1").Resize(1, dic列.Count + 1), 1   '/默认合并
End Sub
Sub 横向合并拆分相容单元格(selection, Optional n As Boolean = True)
    Dim rs, j
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    rs = selection.Columns.Count
    If n Then
        For j = rs To 2 Step -1
            If selection.Cells(1, j) & "" = selection.Cells(1, j - 1) & "" Then
                Union(selection.Cells(1, j), selection.Cells(1, j - 1)).Merge
            End If
        Next
    Else
        For j = 1 To rs
            If selection.Cells(1, j).MergeCells = True Then
                填充内容 = selection.Cells(1, j).MergeArea(1)
                合并列数 = selection.Cells(1, j).MergeArea.Count
                selection.Cells(1, j).MergeArea.UnMerge
                selection.Cells(1, j).Resize(1, 合并列数) = 填充内容
                j = j + 合并列数 - 1
            End If
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

吴中泉

掘掘 发表于 2023-5-23 06:21
Sub 最快法() '//By掘掘,郑广学的学生
    Dim dic As Object, key As String, dickeys, Item, dicItems
...

快是快,但数组brr写死了,并且小了,如代码中ReDim brr(1 To 10000, 1 To 50),你这最大行只有1万,列只有50,假如姓名列为不重复的60人,你这列就装不下了,还有行数也不够,楼主要求最大100万行.

笨鸟飞不高

掘掘 发表于 2023-5-23 06:21
Sub 最快法() '//By掘掘,郑广学的学生
    Dim dic As Object, key As String, dickeys, Item, dicItems
...

大神，厉害啊！原来是郑广学老师的学生，象我们这种自学的估计么很难写出这样高效的代码了。。。

掘掘

吴中泉 发表于 2023-5-23 07:40
快是快,但数组brr写死了,并且小了,如代码中ReDim brr(1 To 10000, 1 To 50),你这最大行只有1万,列只有50, ...

不碍事,redim brr(1 to 任意行,1 to 任意 列)

掘掘

笨鸟飞不高 发表于 2023-5-23 07:47
大神，厉害啊！原来是郑广学老师的学生，象我们这种自学的估计么很难写出这样高效的代码了。。。

自学的也很厉害的。我只是想找个老师，少走点弯路，哈哈。

吴中泉

楼主在一开始说:"其实就是简单的数据透视操作，难的是用VBA来实现一次性完成"
但我用VBA实现起来觉得不是很难,用透视表摆弄几下,却难以实现,请问楼主有什么办法?能告知一下吗?

grf1973

至少给定数据运行没问题的。如果要100万行，sql确实不行，老老实实用数组吧。

·遁去的一·

掘掘 发表于 2023-5-23 08:16
不碍事,redim brr(1 to 任意行,1 to 任意 列)

内存溢出，数据100万行

·遁去的一·

吴中泉 发表于 2023-5-23 10:30
楼主在一开始说:"其实就是简单的数据透视操作，难的是用VBA来实现一次性完成"
但我用VBA实现起来觉得不是 ...

兄弟请移步：https://club.excelhome.net/threa ... tml?_dsign=5e75cb9f

71185843

111111111111111111