【VBA案例007】多条件汇总

归档779

审技265 程技242 投技146 财技57 税技47 法技11 食技7 书技4

653 字

3 分钟

【VBA案例007】多条件汇总

2023-10-23

程技

VBA

浏览量加载中...

大家好！今天回答一位网友的问题。

就是用VBA进行多条件汇总，来实现数据透视表的效果，并且要对结果进行排序。

先来看例子。

假如我们有一份产品信息表，需要对它的所有产品和型号进行汇总。左侧是原始数据，右侧是处理结果。

我们来通过三个不同的方法，来解决这个问题。其中方法一：最容易理解，适合对字典刚入门的情况。方法二：具有有一定的难度，需要对字典有更加深刻的了解。方法三：作为拓展内容。

以下是VBA代码，你也可以直接观看下方的视频解析：

方法一：#

1
Sub 方法一()
2
    Dim i, j, k
3
    Dim ar
4

5
    Dim d1 As Object, d2 As Object, d3 As Object
6
    Set d1 = CreateObject("Scripting.Dictionary")
7
    Set d2 = CreateObject("Scripting.Dictionary")
8
    Set d3 = CreateObject("Scripting.Dictionary")
9

10
    ar = Range("a1:c" & [a65536].End(3).Row)
11

12
    For i = 2 To UBound(ar)
13
        d1(ar(i, 1)) = ""
14
        d2(ar(i, 2)) = ""
15
        d3(ar(i, 1) & ar(i, 2)) = d3(ar(i, 1) & ar(i, 2)) + ar(i, 3)
16
    Next i
17

18
    [f2].Resize(d1.Count) = Application.WorksheetFunction.Transpose(d1.keys)
19
    [g1].Resize(1, d2.Count) = d2.keys
20

21
    For i = 1 To d1.Count
22
        For j = 1 To d2.Count
23
            Cells(i + 1, j + 6) = d3(Cells(i + 1, 6).Value & Cells(1, j + 6).Value)
24
        Next j
25
    Next i
26

27
    'range.Sort
28
    Range("f1").Resize(d1.Count + 1, d2.Count + 1).Sort [f1], xlAscending, , , , , , xlYes, , , xlTopToBottom
29
    Range("g1").Resize(d1.Count + 1, d2.Count).Sort [g1], xlAscending, , , , , , , , , xlLeftToRight
30
End Sub

方法二：#

1
Sub 方法二()
2
    Dim i, j, k
3
    Dim ar, br()
4
    Dim d As Object, kw$
5
    Set d = CreateObject("Scripting.Dictionary")
6
    'd.CompareMode = vbTextCompare '不区分大小写
7
    ar = Range("a1:c" & [a65536].End(3).Row)
8

9
    ReDim br(1 To UBound(ar), 1 To 1000)
10
    Dim rowNum, colNum
11
    rowNum = 1: colNum = 1
12
    For i = 2 To UBound(ar)
13
        '\\型号
14
        If Not d.exists(ar(i, 2)) Then
15
            colNum = colNum + 1
16
            br(1, colNum) = ar(i, 2)
17
            d(ar(i, 2)) = colNum
18
        End If
19

20
        '\\名称
21
        If Not d.exists(ar(i, 1)) Then
22
            rowNum = rowNum + 1
23
            br(rowNum, 1) = ar(i, 1)
24
            d(ar(i, 1)) = rowNum
25
            br(rowNum, d(ar(i, 2))) = ar(i, 3)
26
        Else
27
            br(d(ar(i, 1)), d(ar(i, 2))) = br(d(ar(i, 1)), d(ar(i, 2))) + ar(i, 3)
28
        End If
29

30
    Next i
31

32
    [f1].Resize(rowNum, colNum) = br
33
    Range("f1").Resize(rowNum, colNum).Sort [f1], xlAscending, , , , , , xlYes, , , xlTopToBottom
34
    Range("g1").Resize(rowNum, colNum - 1).Sort [g1], xlAscending, , , , , , , , , xlLeftToRight
35
End Sub

方法三：#

1
Sub SQL查询()
2
    '定义变量
3
    Dim cnn, rst, SQL$
4
    Dim i, j, k
5
    Set cnn = CreateObject("adodb.connection") '创建数据库连接
6
    Set rst = CreateObject("adodb.recordset") '创建一个数据集保存数据
7

8
    '设置数据库连接
9
    If Val(Application.Version) < 12 Then
10
        cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & ThisWorkbook.FullName
11
    Else
12
        cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source=" & ThisWorkbook.FullName
13
    End If
14

15
    '设置SQL语句
16
    SQL = "TRANSFORM SUM(数量) SELECT 名称 from [Sheet1$a1:c18] GROUP BY 名称 PIVOT 型号" '
17

18
    'SQL结果处理
19
    Set rst = cnn.Execute(SQL)
20

21
    Range("f2").CopyFromRecordset rst
22
    For i = 1 To rst.Fields.Count
23
        Cells(1, i + 5) = rst.Fields(i - 1).Name
24
    Next
25

26
    rst.Close
27
    cnn.Close '关闭数据库连接
28
    Set rst = Nothing
29
    Set cnn = Nothing '将cnn从内存中删除
30
End Sub