楼主
wise |
Q:如何在VBA中使用字典进行行列转置？
A：ALT+F11→添加模块→模块中输入以下内容：
- Sub test()
- Dim arr, brr(), d As Object, d2 As Object, i&, m&
- '定义变量
- Set d = CreateObject("scripting.dictionary")
- '创建字典对象，并把字典对象赋给变量d
- Set d2 = CreateObject("scripting.dictionary")
- '创建字典对象，并把字典对象赋给变量d2
- arr = Sheets("sheet1").[a1].CurrentRegion
- '把Sheet1工作表的A1单元格开始的当前区域的值赋给变量arr
- For i = 2 To UBound(arr)
- 'For…Next循环结构，从2开始到数组的最大上界值之间循环。因为数组的第一行是表头。Ubound是VBA函数，返回数组的指定维数的最大可用上界。
- If Not d2.exists(arr(i, 1)) Then
- d2(arr(i, 1)) = d2.Count + 1
- '如果字典d2中不存在arr(i,1)，那么就把字典d2的关键字的数量+1以后赋给这个关键字的项。
- '本例的字典d2的关键字就是类别的不重复值，也就是有多少个不同的类别，为后面的转置列做准备。
- End If
- Next i
- ReDim brr(1 To UBound(arr), 2 To 4 + d2.Count)
- '重新声明变量brr,这里数组变量的第2维从2开始到4 + d2.Count
- For i = 2 To UBound(arr)
- 'For…Next循环结构，再从2开始到数组的最大上界值之间循环一次
- s = arr(i, 2) & Chr(9) & arr(i, 3) & Chr(9) & arr(i, 4)
- '把品名、颜色、客户中间加一个制表符连接成一个关键字赋给变量s
- If Not d.exists(s) Then
- '如果字典d里面没有s这个关键字，那么执行下面的代码
- m = m + 1
- '把变量m+1之后的值赋给变量m
- d(s) = m
- '把变量m的值赋给关键字s的项d(s)
- For j = 2 To 4
- brr(m, j) = arr(i, j)
- '依次把品名、颜色、客户赋给对应的数组变量
- Next
- End If
- brr(d(s), 4 + d2(arr(i, 1))) = brr(d(s), 4 + d2(arr(i, 1))) + arr(i, 5)
- '把不同类别、不同品名颜色客户的数量累加后赋给相应的数组变量
- 'd(s)表示不同品名颜色客户所在的行，d2(arr(i,1))表示不同类别的顺序位置，+4之后就可得到不同类别在数组中的列的位置。
- Next
- With Sheets("Sheet3")
- .[d1].Resize(1, d2.Count) = d2.keys
- '把字典d2的关键字赋给表3的D1单元格开始的区域内。达到把不同的类别显示在D1单元格开始的第一行里面
- .[a2].Resize(m, UBound(brr, 2) - 1) = brr
- '把数组brr的值赋给表3的A2单元格开始的区域内,完成了转置的任务
- End With
- End Sub
 字典转置.rar
|
