求助：用vba两组数据汇总

colin083

见附件：同一表中有两组数据，有相同的人，也有各自不同的人。需要将两组人合并形成一个新的系列。

谢谢各位老师！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet2")
   
7.         For j = 2 To 6 Step 4
   
8.             n = IIf(j = 2, 2, 3)
   
9.             r = .Cells(.Rows.Count, j).End(xlUp).Row
   
10.             arr = .Cells(3, j).Resize(r - 2, 2)
    
11.             For i = 1 To UBound(arr)
    
12.                 If Len(arr(i, 1)) <> 0 Then
    
13.                     If Not d.exists(arr(i, 1)) Then
    
14.                         ReDim brr(1 To 3)
    
15.                         brr(1) = arr(i, 1)
    
16.                     Else
    
17.                         brr = d(arr(i, 1))
    
18.                     End If
    
19.                     brr(n) = arr(i, 2)
    
20.                     d(arr(i, 1)) = brr
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.         .Range("p3").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
    
25.     End With
    
26. End Sub
    

复制代码

cjc209

就是一个步长为2的列循环的问题  结果1列为姓名 2列为工资 3列为奖金 就是了 循环定位取值

chxw68

详见附件。

bxm78

用字典+数组即可实现

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = ActiveSheet.UsedRange
    brr = [o1].Resize(UBound(arr) * 2, 3)
    r = 1
    For j = 2 To UBound(arr)
        For Each i In Array(2, 6)
            If Len(arr(j, i)) > 0 Then
                If d.exists(arr(j, i - 1)) Then
                    rx = d(arr(j, i - 1))
                Else
                    r = r + 1
                    d(arr(j, i - 1)) = r
                    brr(r, 1) = arr(j, i - 1)
                    rx = r
                End If
                If i = 2 Then
                    c = 2
                Else
                    c = 3
                End If
                brr(rx, c) = arr(j, i)
            End If
        Next i
    Next j
    [o1].Resize(r, 3) = brr
End Sub

liulang0808

模拟供参考。。。。。。。。。。。

ykcbf1100

参与一下。

cjc209

答案                             

sxbjzjf110