[已解决]关于字典的问题

如履薄冰_﹌

su45 发表于 2014-9-13 18:24
你没认真试吧？

看附件：

如果在后面单元格填上别的代码，前面的供应商本来为空的，结果是这样。1234前面还有供应商。

su45

你的附件中，那列本应是空的！你使用宏之前是不是应先清空呀！

su45

1. Sub 基础表整理()
   
2. On Error Resume Next
   
3.     Dim a, c As Range, Rng As Range, RG As Range
   
4.     Dim Hx As Long, arr, Brr, d As Object, i&
   
5.     With Sheets("产品信息")
   
6.         arr = .Range("a2:b" & .Range("a65536").End(xlUp).Row)
   
7.     End With
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     For i = 1 To UBound(arr)
   
10.         If Not d.exists(arr(i, 1)) Then
    
11.             d(arr(i, 1)) = arr(i, 2)
    
12.         Else
    
13.             d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
    
14.         End If
    
15.     Next i
    
16.     Brr = Sheets("基础表").Range("d2:d" & Sheets("基础表").Range("d65536").End(xlUp).Row)
    
17.     With Columns("C:C")
    
18.         .Validation.Delete
    
19.         .Font.ColorIndex = 1
    
20.     End With
    
21.     For i = 1 To UBound(Brr)
    
22.         If d.exists(Brr(i, 1)) Then
    
23.             If InStr(d(Brr(i, 1)), ",") Then
    
24.                 With Cells(i + 1, 3).Validation
    
25.                     .Add 3, 1, 1, d(Brr(i, 1))
    
26.                 End With
    
27.                 Cells(i + 1, 3) = Split(d(Brr(i, 1)), ",")(0)
    
28.                 Cells(i + 1, 3).Font.ColorIndex = 3
    
29.             Else
    
30.                 Cells(i + 1, 3) = d(Brr(i, 1))
    
31.             End If
    
32.         Else
    
33.             Cells(i + 1, 3) = ""
    
34.         End If
    
35.     Next
    
36. End Sub

复制代码

如履薄冰_﹌

su45 发表于 2014-9-13 23:27

这样就对了，给你10个赞。