拆分数据

今铭昔

菜狗一只

1. Sub test()
   
2. Dim arr, i As Long, brr() As String, crr, j As Long, k As Long
   
3. Dim mydic As Object
   
4. 
   
5. arr = Me.Range("a1").CurrentRegion
   
6. ReDim crr(1 To 50, 1 To 5)
   
7. Set mydic = CreateObject("scripting.dictionary")
   
8. 
   
9. crr(1, 1) = "时间"
   
10. crr(1, 2) = "地点"
    
11. crr(1, 3) = "陪同人员"
    
12. crr(1, 4) = "人员"
    
13. crr(1, 5) = "性质"
    
14. k = 2
    
15. 
    
16. For i = 2 To UBound(arr, 1)
    
17.   brr = Split(arr(i, 3), "、")
    
18.   
    
19.   For j = 0 To UBound(brr, 1)
    
20.    mydic.Add brr(j), ""
    
21.   Next j
    
22.   
    
23.   For j = 0 To UBound(brr, 1)
    
24.    crr(k, 1) = arr(i, 1)
    
25.    crr(k, 2) = arr(i, 2)
    
26.    
    
27.    mydic.Remove (brr(j))
    
28.    crr(k, 3) = Join(mydic.keys, "、")
    
29.    mydic.Add brr(j), ""
    
30.    
    
31.    crr(k, 4) = brr(j)
    
32.    crr(k, 5) = arr(i, 4)
    
33.    k = k + 1
    
34.   Next j
    
35.   mydic.RemoveAll
    
36. Next i
    
37. 
    
38. Me.Range("g15").Resize(UBound(crr, 1), UBound(crr, 2)).Value = crr
    
39. End Sub
    

复制代码

cpa_cpv