[已解决]关于字典请问下附件中为什么报错，如何解决

tzjx200521

1. Sub hpgld() '合并光缆段
   
2.     Dim arr, x As Long, k1, k, t
   
3.     arr = Sheets("光缆段").UsedRange
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each sh In Sheets
   
6.         If sh.Name = "光缆段1" Then
   
7.             Application.DisplayAlerts = False
   
8.             sh.Delete
   
9.             Application.DisplayAlerts = True
   
10.         End If
    
11.     Next
    
12.     Sheets.Add.Name = "光缆段1"
    
13.     For x = 2 To UBound(arr)
    
14.        k1 = arr(x, 1)
    
15.        If d.exists(k1) Then
    
16.        d(k1) = d(k1) & "<>" & arr(x, 2)
    
17.        Else
    
18.        d(k1) = arr(x, 2)
    
19.        End If
    
20.     Next
    
21.     k = d.keys
    
22.     t = d.Items
    
23.      Sheets("光缆段1").Range("A2").Resize(d.Count) = Application.Transpose(k)
    
24.      Sheets("光缆段1").Range("b2").Resize(d.Count) = Application.Transpose(t)
    
25. End Sub
    

复制代码

最佳答案

月排行榜 / 总排行榜

france723

2017-5-20 23:12

1. Sub hpgld() '合并光缆段
   
2.     Dim arr, x As Long, k1, k, t, n，y, m
   
3.     arr = Sheets("光缆段").UsedRange
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each sh In Sheets
   
6.         If sh.Name = "光缆段1" Then
   
7.             Application.DisplayAlerts = False
   
8.             sh.Delete
   
9.             Application.DisplayAlerts = True
   
10.         End If
    
11.     Next
    
12.     Sheets.Add.Name = "光缆段1"
    
13.     For x = 2 To UBound(arr)
    
14.        k1 = arr(x, 1)
    
15.        If d.exists(k1) Then
    
16.        d(k1) = d(k1) & "<>" & arr(x, 2)
    
17.        Else
    
18.        d(k1) = arr(x, 2)
    
19.        End If
    
20.     Next
    
21.     k = d.keys
    
22.      Sheets("光缆段1").Range("A2").Resize(d.Count) = Application.Transpose(k)
    
23.      y = Sheets("光缆段1").Range("a65536").End(3).Row
    
24.      For n = 2 To y
    
25.         m = Sheets("光缆段1").Range("A" & n)
    
26.         Sheets("光缆段1").Range("B" & n) = d(m)
    
27.      Next n
    
28. End Sub

复制代码

字典里key和Item相互对应，不能像你那样直接派出所有ITEM，和你KEY对不上

跳转到最佳答案楼层

france723

1. Sub hpgld() '合并光缆段
   
2.     Dim arr, x As Long, k1, k, t, n，y, m
   
3.     arr = Sheets("光缆段").UsedRange
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each sh In Sheets
   
6.         If sh.Name = "光缆段1" Then
   
7.             Application.DisplayAlerts = False
   
8.             sh.Delete
   
9.             Application.DisplayAlerts = True
   
10.         End If
    
11.     Next
    
12.     Sheets.Add.Name = "光缆段1"
    
13.     For x = 2 To UBound(arr)
    
14.        k1 = arr(x, 1)
    
15.        If d.exists(k1) Then
    
16.        d(k1) = d(k1) & "<>" & arr(x, 2)
    
17.        Else
    
18.        d(k1) = arr(x, 2)
    
19.        End If
    
20.     Next
    
21.     k = d.keys
    
22.      Sheets("光缆段1").Range("A2").Resize(d.Count) = Application.Transpose(k)
    
23.      y = Sheets("光缆段1").Range("a65536").End(3).Row
    
24.      For n = 2 To y
    
25.         m = Sheets("光缆段1").Range("A" & n)
    
26.         Sheets("光缆段1").Range("B" & n) = d(m)
    
27.      Next n
    
28. End Sub

复制代码

字典里key和Item相互对应，不能像你那样直接派出所有ITEM，和你KEY对不上