[已解决]用VBA数组或字典统计出右表职称内容

laoau138

  用VBA数组或字典统计出右表职称内容

最佳答案

月排行榜 / 总排行榜

xyzxyz07

2017-6-21 18:30

Private Sub CommandButton1_Click()
    Dim d1 As New Dictionary, d2 As New Dictionary
    Dim arr1, arr2(), i1 As Integer, i2 As Integer, i3 As Integer
    arr1 = Range("A3:E" & Range("A65536").End(xlUp))
    i2 = 0
    i3 = 0
    For i1 = 1 To UBound(arr1)
    If Not d1.Exists(arr1(i1, 3)) Then
        i2 = i2 + 1
        d1(arr1(i1, 3)) = i2
    End If
    If Not d2.Exists(arr1(i1, 4)) Then
        i3 = i3 + 1
        d2(arr1(i1, 4)) = i3
    End If
    Next
    ReDim arr2(1 To i2 + 3, 1 To i3 * 2 + 3)
    arr2(1, 1) = "职称"
    arr2(i2 + 3, 1) = "合计"
    arr2(1, i3 * 2 + 2) = "合计"
    For i1 = 1 To UBound(arr1)
        arr2(1, d2(arr1(i1, 4)) * 2) = arr1(i1, 4)
        arr2(2, d2(arr1(i1, 4)) * 2) = "人数"
        arr2(2, d2(arr1(i1, 4)) * 2 + 1) = "金额"
        arr2(2, i3 * 2 + 2) = "人数"
        arr2(2, i3 * 2 + 3) = "金额"
        arr2(d1(arr1(i1, 3)) + 2, 1) = arr1(i1, 3)
        arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 2) = arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 2) + 1 'arr1(i1, 5)
        arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 3) = arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 3) + arr1(i1, 5)
        arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2) = arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2) + 1 'arr1(i1, 5)
        arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2 + 1) = arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2 + 1) + arr1(i1, 5)
        arr2(i2 + 3, d2(arr1(i1, 4)) * 2) = arr2(i2 + 3, d2(arr1(i1, 4)) * 2) + 1
        arr2(i2 + 3, d2(arr1(i1, 4)) * 2 + 1) = arr2(i2 + 3, d2(arr1(i1, 4)) * 2 + 1) + arr1(i1, 5)
        arr2(i2 + 3, i3 * 2 + 2) = arr2(i2 + 3, i3 * 2 + 2) + 1
        arr2(i2 + 3, i3 * 2 + 3) = arr2(i2 + 3, i3 * 2 + 3) + arr1(i1, 5)
    Next
    [O2].Resize(i2 + 3, i3 * 2 + 3) = arr2
End Sub

跳转到最佳答案楼层

laoau138

谁来做一下

xyzxyz07

Private Sub CommandButton1_Click()
    Dim d1 As New Dictionary, d2 As New Dictionary
    Dim arr1, arr2(), i1 As Integer, i2 As Integer, i3 As Integer
    arr1 = Range("A3:E" & Range("A65536").End(xlUp))
    i2 = 0
    i3 = 0
    For i1 = 1 To UBound(arr1)
    If Not d1.Exists(arr1(i1, 3)) Then
        i2 = i2 + 1
        d1(arr1(i1, 3)) = i2
    End If
    If Not d2.Exists(arr1(i1, 4)) Then
        i3 = i3 + 1
        d2(arr1(i1, 4)) = i3
    End If
    Next
    ReDim arr2(1 To i2 + 3, 1 To i3 * 2 + 3)
    arr2(1, 1) = "职称"
    arr2(i2 + 3, 1) = "合计"
    arr2(1, i3 * 2 + 2) = "合计"
    For i1 = 1 To UBound(arr1)
        arr2(1, d2(arr1(i1, 4)) * 2) = arr1(i1, 4)
        arr2(2, d2(arr1(i1, 4)) * 2) = "人数"
        arr2(2, d2(arr1(i1, 4)) * 2 + 1) = "金额"
        arr2(2, i3 * 2 + 2) = "人数"
        arr2(2, i3 * 2 + 3) = "金额"
        arr2(d1(arr1(i1, 3)) + 2, 1) = arr1(i1, 3)
        arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 2) = arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 2) + 1 'arr1(i1, 5)
        arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 3) = arr2(d1(arr1(i1, 3)) + 2, i3 * 2 + 3) + arr1(i1, 5)
        arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2) = arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2) + 1 'arr1(i1, 5)
        arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2 + 1) = arr2(d1(arr1(i1, 3)) + 2, d2(arr1(i1, 4)) * 2 + 1) + arr1(i1, 5)
        arr2(i2 + 3, d2(arr1(i1, 4)) * 2) = arr2(i2 + 3, d2(arr1(i1, 4)) * 2) + 1
        arr2(i2 + 3, d2(arr1(i1, 4)) * 2 + 1) = arr2(i2 + 3, d2(arr1(i1, 4)) * 2 + 1) + arr1(i1, 5)
        arr2(i2 + 3, i3 * 2 + 2) = arr2(i2 + 3, i3 * 2 + 2) + 1
        arr2(i2 + 3, i3 * 2 + 3) = arr2(i2 + 3, i3 * 2 + 3) + arr1(i1, 5)
    Next
    [O2].Resize(i2 + 3, i3 * 2 + 3) = arr2
End Sub

laoau138

xyzxyz07 发表于 2017-6-21 18:30
Private Sub CommandButton1_Click()
    Dim d1 As New Dictionary, d2 As New Dictionary
    Dim arr1 ...

再贴几个答案

Private Sub CommandButton1_Click()
Dim d, d1, arr()
Set d = CreateObject("Scripting.Dictionary")
ii = 0: iii = 0
x = Range("A65536").End(xlUp).Row
ReDim arr(1 To x, 1 To 30)
For i = 3 To x
    d("职称=" & Cells(i, 3).Value) = 0
    d("部门=" & Cells(i, 4).Value) = 0
    d(Cells(i, 3).Value & Cells(i, 4).Value & "人数") = d(Cells(i, 3).Value & Cells(i, 4).Value & "人

数") + 1
    d(Cells(i, 3).Value & Cells(i, 4).Value & "金额") = d(Cells(i, 3).Value & Cells(i, 4).Value & "金

额") + Cells(i, 5)
    d(Cells(i, 3).Value & "合计人数") = d(Cells(i, 3).Value & "合计人数") + 1
    d(Cells(i, 3).Value & "合计金额") = d(Cells(i, 3).Value & "合计金额") + Cells(i, 5)
    d("合计" & Cells(i, 4).Value & "人数") = d("合计" & Cells(i, 4).Value & "人数") + 1
    d("合计" & Cells(i, 4).Value & "金额") = d("合计" & Cells(i, 4).Value & "金额") + Cells(i, 5)
Next i
k = d.Keys
arr(1, 1) = "职称"
For i = 1 To UBound(k)
    If Left(k(i - 1), 3) = "职称=" Then
        arr(3 + ii, 1) = Right(k(i - 1), Len(k(i - 1)) - 3)
        ii = ii + 1
    ElseIf Left(k(i - 1), 3) = "部门=" Then
        iii = iii + 1
        arr(1, iii * 2) = Right(k(i - 1), Len(k(i - 1)) - 3)
        arr(2, iii * 2) = "人数"
        arr(2, iii * 2 + 1) = "金额"
    End If
Next i
        arr(3 + ii, 1) = "合计"
        iii = iii + 1
        arr(1, iii * 2) = "合计"
        arr(2, iii * 2) = "人数"
        arr(2, iii * 2 + 1) = "金额"
For i = 3 To ii + 3
    For j = 2 To iii * 2 + 1
        jtemp = 1
        If j Mod 2 = 0 Then jtemp = 0
        arr(i, j) = d(arr(i, 1) & arr(1, j - jtemp) & arr(2, j))
    Next j
Next i
    arr(ii + 3, iii * 2) = x - 2
    arr(ii + 3, iii * 2 + 1) = Application.Sum(Range(Cells(3, 5), Cells(x, 5)))
[o12].Resize(ii + 3, iii * 2 + 1) = arr
MsgBox "done"
End Sub

laoau138

Sub s()
    arr = [a1].CurrentRegion
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    r = 3
    c = 2
    For i = 3 To UBound(arr)
        If Not d1.Exists(arr(i, 3)) Then
            d1(arr(i, 3)) = r
            r = r + 1
        End If
        If Not d2.Exists(arr(i, 4)) Then
            d2(arr(i, 4)) = c
            c = c + 2
        End If
    Next
    c = c + 1
    ReDim brr(1 To r, 1 To c)
    For i = 3 To UBound(arr)
        x = d1(arr(i, 3))
        y = d2(arr(i, 4))
        brr(x, y) = brr(x, y) + 1
        brr(x, y + 1) = brr(x, y + 1) + arr(i, 5)
        brr(r, y) = brr(r, y) + 1
        brr(r, y + 1) = brr(r, y + 1) + arr(i, 5)
        brr(x, c - 1) = brr(x, c - 1) + 1
        brr(x, c) = brr(x, c) + arr(i, 5)
    Next
    brr(1, 1) = "职称"
    brr(r, 1) = "合计"
    brr(1, c - 1) = "合计"
    brr(2, c) = "人数"
    brr(2, c - 1) = "金额"
    k1 = d1.Keys
    k2 = d2.Keys
    For i = 3 To r - 1
        brr(i, 1) = k1(i - 3)
        brr(r, c - 1) = brr(r, c - 1) + brr(i, c - 1)
        brr(r, c) = brr(r, c) + brr(i, c)
    Next
    For i = 0 To d2.Count - 1
        brr(1, i * 2 + 2) = k2(i)
        brr(2, i * 2 + 2) = "人数"
        brr(2, i * 2 + 3) = "金额"
    Next
    [o12].Resize(r, c) = brr
End Sub

大灰狼1976

1. Sub aaa()
   
2. Dim arr, brr(1 To 1000, 1 To 13), i&, j&, d As Object, r&, c&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. r = 2
   
6. brr(1, 1) = "职称"
   
7. For j = 2 To 12 Step 2
   
8.   brr(1, j) = j / 2
   
9.   brr(2, j) = "人数"
   
10.   brr(2, j + 1) = "金额"
    
11. Next j
    
12. brr(1, 12) = "合计"
    
13. For i = 3 To UBound(arr)
    
14.   If Not d.Exists(arr(i, 3)) Then
    
15.     r = r + 1
    
16.     d(arr(i, 3)) = r
    
17.     brr(r, 1) = arr(i, 3)
    
18.   End If
    
19.   c = arr(i, 4) * 2
    
20.   brr(d(arr(i, 3)), c) = brr(d(arr(i, 3)), c) + 1
    
21.   brr(d(arr(i, 3)), c + 1) = brr(d(arr(i, 3)), c + 1) + arr(i, 5)
    
22.   brr(d(arr(i, 3)), 12) = brr(d(arr(i, 3)), 12) + 1
    
23.   brr(d(arr(i, 3)), 13) = brr(d(arr(i, 3)), 13) + arr(i, 5)
    
24. Next i
    
25. brr(r + 1, 1) = "合计"
    
26. For j = 2 To 13
    
27.   For i = 3 To r
    
28.     brr(r + 1, j) = brr(r + 1, j) + brr(i, j)
    
29.   Next i
    
30. Next j
    
31. [o12].Resize(r + 1, 13) = brr
    
32. End Sub

复制代码