我想利用字典整理我的数据，但得不到结果，请大侠帮忙修改下

eutu

我想利用字典整理某种要求，重新整理数据，但得不到结果，请大侠帮忙修改下
我自己看我的代码，似乎没问题，就是不出结果，但又找不出改进的方法了，请大师帮忙看看


工作簿1.rar (14.32 KB, 下载次数: 11)

2019-12-18 09:52 上传

点击文件名下载附件

microyip

1. Sub fdert()
   
2.     Dim i%, ar
   
3.     On Error Resume Next
   
4.    
   
5.     Set dhy = CreateObject("Scripting.Dictionary")
   
6.     arr = Range("a1").CurrentRegion
   
7. 
   
8.     For i = 2 To UBound(arr)
   
9.         hy = arr(i, 2)
   
10.         nam = arr(i, 1)
    
11.         proportion = arr(i, 3)
    
12.         If Not dhy.exists(hy) Then dhy(hy) = Array(0, "")
    
13.         arrhy = dhy(hy)
    
14.         arrhy(0) = arrhy(0) + proportion
    
15.         If arrhy(1) <> "" Then arrhy(1) = arrhy(1) & "/"
    
16.         arrhy(1) = arrhy(1) & nam
    
17.         dhy(hy) = arrhy
    
18.     Next i
    
19. 
    
20.     If dhy.Count <> 0 Then
    
21.         For i = 0 To dhy.Count
    
22.             Cells(16 + i, 1) = dhy.Keys()(i)
    
23.             Cells(16 + i, 2) = dhy.items()(i)(0)
    
24.             Cells(16 + i, 3) = dhy.items()(i)(1)
    
25.         Next
    
26.     End If
    
27.    
    
28. End Sub

复制代码

魂断蓝桥

Sub a()
Dim d, i%, m%, arr, brr(1 To 100, 1 To 3), s$
arr = [a1].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
    s = arr(i, 2)
    If Not d.exists(s) Then
        m = m + 1
        d(s) = m
        brr(m, 1) = arr(i, 2)
        brr(m, 2) = arr(i, 3)
        brr(m, 3) = arr(i, 1)
  Else
        brr(d(s), 2) = brr(d(s), 2) + arr(i, 3)
        If Not InStr(brr(d(s), 3), arr(i, 1)) Then
            brr(d(s), 3) = brr(d(s), 3) & "/" & arr(i, 1)
       End If
    End If
Next
[a11].Resize(m, 3) = brr
Set d = Nothing
End Sub

蓝桥玄霜

字典的代码：