请教一个数据透视表的VBA

jsjcjsjc

这个是录制的宏,怎么把范围改成"当前"sheet的E列到G列?


背景:
就是把当前sheet的E列到G列进行数据透视,E列放"行",F和G求和放"值"
网上查了一下教程似乎都挺麻烦的,代码好多哈~~自己录制报错了..
感谢,五一快乐
工作簿1.zip (14.33 KB, 下载次数: 15)

2023-5-3 10:18 上传

点击文件名下载附件

1.     Columns("E:G").Select
   
2.     Range("G1").Activate
   
3.     Application.CutCopyMode = False
   
4.     Sheets.Add
   
5.     ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
   
6.         "叠词数据!R1C5:R1048576C7", Version:=8).CreatePivotTable TableDestination:= _
   
7.         "Sheet2!R3C1", TableName:="数据透视表2", DefaultVersion:=8

复制代码

3190496160

既然想用vba了，那就直接用vba代码来实现数据透视表的效果就行了吧？
无非就是一个分类汇总问题而已，关键是目前的附件太过于简单，连数据源是哪个工作表都弄不清楚，也就没法写代码了

jsjcjsjc

3190496160 发表于 2023-5-3 16:15
既然想用vba了，那就直接用vba代码来实现数据透视表的效果就行了吧？
无非就是一个分类汇总问题而已，关键 ...

感谢,回复

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
    r = .Cells(Rows.Count, 5).End(xlUp).Row
    ar = .Range("e1:g" & r)
End With
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
    If Trim(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
        br(t, 2) = br(t, 2) + ar(i, 2)
        br(t, 3) = br(t, 3) + ar(i, 3)
        hj_1 = hj_1 + ar(i, 2)
        hj_2 = hj_2 + ar(i, 3)
    End If
Next i
k = k + 1
br(k, 1) = "合计"
br(k, 2) = hj_1
br(k, 3) = hj_2
With Sheets("Sheet2-结果")
    .[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
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

工作簿1.rar (22.24 KB, 下载次数: 12)

2023-5-3 19:08 上传

点击文件名下载附件

海好呀

jsjcjsjc 发表于 2023-5-3 17:00
感谢,回复

附件仅供参考，可以依据你的实际需求更改~~

吴中泉

直接上图片，省得审核，代码很简单，如图

吴中泉

'再来一个

1. Sub 分类汇总2()
   
2. Dim arr As Variant, d As Object
   
3. Dim i As Long, k As Long, j As Long
   
4. Set d = CreateObject("scripting.dictionary")
   
5. With Sheets("Sheet1")
   
6.     r = .Cells(Rows.Count, 5).End(xlUp).Row
   
7.     arr = .Range("e1:g" & r)
   
8. End With
   
9. k = 1
   
10. For i = 2 To UBound(arr)
    
11.     If "" = d(arr(i, 1)) Then
    
12.         k = k + 1
    
13.         d(arr(i, 1)) = k
    
14.         arr(k, 1) = arr(i, 1)
    
15.         arr(k, 2) = arr(i, 2)
    
16.         arr(k, 3) = arr(i, 3)
    
17.     Else
    
18.         j = d(arr(i, 1))
    
19.         arr(j, 1) = arr(i, 1)
    
20.         arr(j, 2) = arr(j, 2) + arr(i, 2)
    
21.         arr(j, 3) = arr(j, 3) + arr(i, 3)
    
22.     End If
    
23.     hj_1 = hj_1 + arr(i, 2)
    
24.     hj_2 = hj_2 + arr(i, 3)
    
25. Next i
    
26. k = k + 1
    
27. arr(k, 1) = "合计"
    
28. arr(k, 2) = hj_1
    
29. arr(k, 3) = hj_2
    
30. With Sheets("Sheet2-结果")
    
31.     .[a1].CurrentRegion.Offset(1).Borders.LineStyle = 0
    
32.     .[a1].CurrentRegion.Offset(1) = Empty
    
33.     .[a1].Resize(k, UBound(arr, 2)) = arr
    
34.     .[a1].Resize(k, UBound(arr, 2)).Borders.LineStyle = 1
    
35. End With
    
36. 'MsgBox "ok!"
    
37. End Sub
    
38. 
    

复制代码

jsjcjsjc

3190496160 发表于 2023-5-3 19:08

感谢大佬,问一下为什么都用字典? 而不用数据透视?
因为数据有100万,所以字典效率不行哈

3190496160

jsjcjsjc 发表于 2023-5-6 08:52
感谢大佬,问一下为什么都用字典? 而不用数据透视?
因为数据有100万,所以字典效率不行哈

呵呵呵，谁告诉你的字典不行？
100万行数据，就不适合用excel了，用数据库吧，
在excel中透视100万行数据你试试看看，呵呵