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

笨鸟飞不高 · 发表于 2023-5-23 12:56

本帖最后由笨鸟飞不高于 2023-5-23 13:01 编辑

数据透视表分类汇总.zip (135.64 KB, 下载次数: 14)

掘掘 · 发表于 2023-5-23 13:36

·遁去的一· 发表于 2023-5-23 11:23
内存溢出，数据100万行

不可能，100万行完全可以。
我测试了，可以

你输出到其他表，或者先把原表除了数据源，其他的列全部都删除了再运行

71185843 · 发表于 2023-5-23 14:15

Option Explicit
Function 分类汇总(arr, brr, rng As Range) ''brr选择任意列 [{2,3,4,5}]
Dim i, j, k, r As Range, dic选择列, key, dic单位, m, n, 行, 列, crr, dic, dic1, drr
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
Set dic单位 = CreateObject("scripting.dictionary")
Set dic选择列 = CreateObject("scripting.dictionary")
For i = LBound(arr) To UBound(arr)
      If Not dic.Exists(key) Then
         dic(arr(i, 1)) = ""
      End If
      For j = 2 To UBound(arr, 2)
         If Not dic1.Exists(key) Then
            dic1(arr(i, j)) = ""
         End If
      Next
Next
ReDim crr(1 To dic.Count + 2, 1 To dic1.Count + 1)
crr(1, 1) = arr(1, 1)
ReDim drr(1 To UBound(brr) + 1)
drr(1) = 1
For j = 1 To UBound(brr)
      For i = 2 To UBound(arr)
         key = arr(i, 1)
         If j = 1 Then
            If Not dic单位.Exists(key) Then
                  m = m + 1
                  dic单位(key) = m + 2
                  crr(m + 2, 1) = key
            End If
         End If
         行 = dic单位(key)
         key = arr(i, brr(j))
         If Not dic选择列.Exists(key) Then
            n = n + 1
            dic选择列(key) = n + 1
            crr(1, n + 1) = arr(1, brr(j))
            crr(2, n + 1) = key
         End If
         列 = dic选择列(key)
         crr(行, 列) = Val(crr(行, 列)) + 1
      Next
      drr(j + 1) = n + 1
Next
crr(m + 3, 1) = "合计"
For i = 3 To m + 2
      For j = 2 To n + 1
         crr(m + 3, j) = crr(m + 3, j) + crr(i, j)
      Next
Next
With rng.Resize(m + 3, n + 1)
      .Clear
      .Value = crr
      .Borders.LineStyle = xlContinuous
      .HorizontalAlignment = xlCenter
End With
rng.Resize(2, 1).Merge
With rng.Parent
      For j = 2 To UBound(drr)
         .Range(Cells(1, drr(j - 1) + 1), Cells(1, drr(j))).Merge
      Next
End With
Application.ScreenUpdating = True
End Function
Sub text()
Dim arr, t
t = Timer
arr = Sheet1.[a1].CurrentRegion
分类汇总 arr, [{2,3,4,5}], Sheet2.[a1]
MsgBox "完成！耗时： " & Format(Timer - t, "0.00" & "秒"), , "提示"
End Sub

吴中泉 · 发表于 2023-5-23 15:23

·遁去的一· 发表于 2023-5-23 11:23
内存溢出，数据100万行

楼主最好把100万行的数据发到帖子里来,或者你是怎么模拟数据测试的,告诉我们一下,我们自己调试一下代码

·遁去的一· · 发表于 2023-5-23 15:32

掘掘发表于 2023-5-23 13:36
不可能，100万行完全可以。
我测试了，可以
你输出到其他表，或者先把原表除了数据源，其他的列全部 ...

多次测试均未通过，不是下标越界就是内存溢出，上传不了附件，太大了，你们可以自己生成100万行啊，写一段代码就行

Sub 生成100万行数据()
Dim ws As Worksheet
Dim rowCount As Long
Dim dataRange As Range
Dim i As Long
' 设置要操作的工作表
Set ws = ThisWorkbook.Worksheets("Sheet1") ' 将"Sheet1"替换为您实际的工作表名称
' 设置生成数据的行数
rowCount = 1000000
' 获取数据填充范围
Set dataRange = ws.Range("A2:A" & rowCount + 1) ' 假设数据填充范围为A2:A1000001
' 生成数据
For i = 1 To rowCount
dataRange.Cells(i).Value = "数据" & i ' 根据需求生成相应的数据
Next i
MsgBox "生成100万行数据完成。"
End Sub

复制代码

吴中泉 · 发表于 2023-5-23 19:58

·遁去的一· 发表于 2023-5-23 15:32
多次测试均未通过，不是下标越界就是内存溢出，上传不了附件，太大了，你们可以自己生成100万行啊，写一 ...

经过调整，实现了以任意列作为行标题统计数据，形成各式报表，如下图中右边四个小表。
（这样表述可对？）表述不准，看图知意

吴中泉 · 发表于 2023-5-23 20:03

附上附件：

类似数据透视的复杂合并汇总.rar (34.62 KB, 下载次数: 12)

吴中泉 · 发表于 2023-5-23 20:14

·遁去的一· 发表于 2023-5-23 15:32
多次测试均未通过，不是下标越界就是内存溢出，上传不了附件，太大了，你们可以自己生成100万行啊，写一 ...

楼主这代码写的挺好的呀，是不是扮猪吃老虎啊

吴中泉 · 发表于 2023-5-23 20:53

·遁去的一· 发表于 2023-5-23 15:32
多次测试均未通过，不是下标越界就是内存溢出，上传不了附件，太大了，你们可以自己生成100万行啊，写一 ...

楼主，请用这段代码，生成100万行数据会很快，只要几秒

Sub 生成100万行数据()
Dim ws As Worksheet
Dim rowCount As Long
Dim dataRange As Range
Dim i As Long
' 设置要操作的工作表
Set ws = ThisWorkbook.Worksheets("数据源") ' 将"Sheet1"替换为您实际的工作表名称
' 设置生成数据的行数
rowCount = 1000000
' 获取数据填充范围
Set dataRange = ws.Range("A7:A" & rowCount + 1) ' 假设数据填充范围为A2:A1000001
' 生成数据
ReDim arr(1 To rowCount)
For i = 1 To rowCount
arr(i) = "数据" & i ' 根据需求生成相应的数据
Next i
dataRange = WorksheetFunction.Transpose(arr)
MsgBox "生成100万行数据完成。"
End Sub

复制代码

·遁去的一· · 发表于 2023-5-23 21:08

吴中泉发表于 2023-5-23 19:58
经过调整，实现了以任意列作为行标题统计数据，形成各式报表，如下图中右边四个小表。
（这样表述可对 ...

比我要求的更多功能了，大神居然用WPS

		自动登录	找回密码
密码			免费注册

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

评分