他山之石——使用VBA字典-Part3

这部分算是VBA字典的高级用法了，竟然可以实现透视表功能，确实很强大！

Sub 下棋法之多列汇总()
 Dim 棋盘(1 To 10000, 1 To 3)
 Dim 行数
 Dim arr, x, k
 Dim d As New Dictionary
 arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
 For x = 1 To UBound(arr)
   If d.Exists(arr(x, 1)) Then
      行数 = d(arr(x, 1))
      棋盘(行数, 2) = 棋盘(行数, 2) + arr(x, 2)
      棋盘(行数, 3) = 棋盘(行数, 3) + arr(x, 3)
   Else
      k = k + 1
      d(arr(x, 1)) = k
      棋盘(k, 1) = arr(x, 1)
      棋盘(k, 2) = arr(x, 2)
      棋盘(k, 3) = arr(x, 3)
   End If
 Next x
 Range("f2").Resize(k, 3) = 棋盘
End Sub


Sub 下棋法之多条件多列汇总()
 Dim 棋盘(1 To 10000, 1 To 4)
 Dim 行数
 Dim arr, x As Integer, sr As String, k As Integer
 Dim d As New Dictionary
 arr = Range("a2:d" & Range("a65536").End(xlUp).Row)
 For x = 1 To UBound(arr)
    sr = arr(x, 1) & "-" & arr(x, 2)
    If d.Exists(sr) Then
      行数 = d(sr)
      棋盘(行数, 3) = 棋盘(行数, 3) + arr(x, 3)
      棋盘(行数, 4) = 棋盘(行数, 4) + arr(x, 4)
    Else
      k = k + 1
      d(sr) = k
      棋盘(k, 1) = arr(x, 1)
      棋盘(k, 2) = arr(x, 2)
      棋盘(k, 3) = arr(x, 3)
      棋盘(k, 4) = arr(x, 4)
    End If
 Next x
   Range("g2").Resize(k, 4) = 棋盘
End Sub

Sub 下棋法之数据透视表式汇总()
 Dim d As New Dictionary
 Dim 棋盘(1 To 10000, 1 To 7)
 Dim 行数, 列数
 Dim arr, x, k
 
 arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
 
 For x = 1 To UBound(arr)
   列数 = (InStr("1月2月3月4月5月6月", arr(x, 2)) + 1) / 2 + 1
   If d.Exists(arr(x, 1)) Then
      行数 = d(arr(x, 1))
      
      棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 3)
   Else
      k = k + 1
      d(arr(x, 1)) = k
      棋盘(k, 1) = arr(x, 1)
      棋盘(k, 列数) = arr(x, 3)
   End If
 Next x
 
 Range("f2").Resize(k, 7) = 棋盘

End Sub