|
- Sub qq()
- Dim d As Object, m%, n%, j%
- Dim d1 As Object
- Dim r%, i%
- Dim arr, brr
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- r = Cells(Rows.Count, 1).End(xlUp).Row
- arr = Range("a1:d" & r)
- ReDim brr(1 To UBound(arr), 1 To 20)
- For j = 2 To UBound(arr)
- If Not d1.Exists(arr(j, 4)) Then
- m = m + 1
- d1(arr(j, 4)) = m
- End If
- If Not d.Exists(arr(j, 2)) Then
- n = n + 1
- d(arr(j, 2)) = n
- brr(n + 1, 1) = arr(j, 2)
- End If
- brr(d(arr(j, 2)) + 1, d1(arr(j, 4)) + 1) = arr(j, 3)
- Next
- brr(1, 1) = "户主姓名"
- For i = 2 To m + 1
- brr(1, i) = d1.keys()(i - 2)
- Next
- Columns("f:m").Clear
- [f4:l4].Resize(n + 1) = brr
- End Sub
复制代码 |
|