请教各位老师关于数据整理的问题

zhong1218

如题，具体请看附件，谢谢各位老师！

不知道为什么

字典和数组 可以

liujialin0o0

写的不好,清测试

1. Sub zl()
   
2. 
   
3. Sheets(1).Activate
   
4. a = Cells(Rows.Count, 3).End(3).Row
   
5. Set arr = Sheets(1).Range(Cells(2, 3), Cells(a, 3))
   
6. Sheets(1).Range(Cells(2, 7), Cells(a, 13)).ClearContents
   
7. Sheets(2).Activate
   
8. b = Cells(Rows.Count, 6).End(3).Row
   
9. Set brr = Sheets(2).Range(Cells(2, 6), Cells(b, 3))
   
10. 
    
11. For Each rng1 In arr
    
12.     If brr.Find(rng1) Is Nothing Then
    
13.         rng1.Offset(0, 4) = "此人不存在"
    
14.     Else
    
15.         For Each rng2 In brr
    
16.             If rng2 = rng1 Then
    
17.                 rng1.End(xlToRight).Offset(0, 1) = rng2.Offset(0, 1)
    
18.                 rng1.End(xlToRight).Offset(0, 1) = rng2.Offset(0, 2)
    
19.             End If
    
20.         Next
    
21.     End If
    
22. Next
    
23. Sheets(1).Activate
    
24. [A1].Select
    
25. End Sub

复制代码

魂断蓝桥

Sub a()
Dim arr, brr(1 To 9999, 1 To 13), d1, d2, i%, m%
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
arr = Sheets("表2").[a1].CurrentRegion
For i = 2 To UBound(arr)
    If Not d1.exists(arr(i, 6)) Then
        m = m + 1
        brr(m, 1) = arr(i, 4)
        brr(m, 2) = arr(i, 6)
        brr(m, 3) = 14300
        brr(m, 6) = arr(i, 7)
        brr(m, 7) = arr(i, 8)
        d1(arr(i, 6)) = m
    Else
        d2(arr(i, 6)) = d2(arr(i, 6)) + 1
        brr(d1(arr(i, 6)), (d2(arr(i, 6)) - 1) * 2 + 8) = arr(i, 7)
        brr(d1(arr(i, 6)), (d2(arr(i, 6)) - 1) * 2 + 9) = arr(i, 8)
    End If
Next
For i = 1 To m
    brr(i, 4) = brr(i, 7) + brr(i, 9) + brr(i, 11) + brr(i, 13)
    brr(i, 5) = brr(i, 3) - brr(i, 4)
Next
With Sheet1
    .[b2:n9999] = ""
    .[b2].Resize(m, 13) = brr
End With

Set d1 = Nothing
Set d2 = Nothing

End Sub

jnsxmt

是否符合要求，请审阅

ahnyt

测试，是不是这个结果，符合就送花。

不知道为什么

如图

不知道为什么

参考