字典求简化，是否可在item里直接拆分 处理后 再合并呢

abc3479

1. Sub TestSub()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Dim arr: arr = Range("a1").CurrentRegion
   
4.     For i = 3 To UBound(arr)
   
5.         If Not d.exists(arr(i, 1)) Then
   
6.             d(arr(i, 1)) = arr(i, 2)
   
7.         Else
   
8.             If d(arr(i, 1)) <> arr(i, 2) Then '去重
   
9.                 d(arr(i, 1)) = d(arr(i, 1)) & "/" & arr(i, 2)
   
10.             End If
    
11.         End If
    
12.     Next
    
13.     [d3].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
14.    
    
15. End Sub

复制代码

tcdatongye

abc3479 发表于 2024-7-30 10:14

Sub aa()
Set dic = VBA.CreateObject("scripting.dictionary")
With Sheets(1)
  t = .Cells(1, 1).End(xlDown).Row
  For i = 3 To t
    s = .Cells(i, 1).Value
    If Not dic.exists(s) Then
        dic(s) = .Cells(i, 2)
      ElseIf InStr(dic(s), .Cells(i, 2)) = 0 Then
        dic(s) = dic(s) & "/" & .Cells(i, 2)
    End If
  Next i
  .Cells(3, 10).Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
End With
End Sub

titi012

参与一下。。。。

1. Sub test()
   
2.     Dim Arr, Trr, i&, j&
   
3.     Dim aTyps As New Typs
   
4.     Arr = Range("a3:b" & Cells(Rows.Count, 2).End(xlUp).Row)
   
5.     For i = LBound(Arr) To UBound(Arr)
   
6.         Trr = Split(Arr(i, 2), "/")
   
7.         For j = LBound(Trr) To UBound(Trr)
   
8.             aTyps.Add Arr(i, 1), Trr(j)
   
9.         Next j
   
10.     Next i
    
11.     Range("d3").Resize(aTyps.Count, 2) = aTyps.Data
    
12. End Sub

复制代码

jerry3770

titi012 发表于 2024-7-30 14:14
参与一下。。。。

谢谢老师指导  谢谢参与。结果正确。我添加了一些数据 发现有两段有bug（其他老师的）  我的是WPS 2016专业版。

jerry3770

quqiyuan 发表于 2024-7-29 18:17
按照楼主后面要求，每个单元格里也排重，用了双字典，仅供参考。。。

老师  我添加了一些数据   上传了附件到24楼  发现您这段代码也是有bug的  您有空帮看看。谢谢

jerry3770

ykcbf1100 发表于 2024-7-29 18:19
更新一下。。。

老师  我添加了一些数据   上传了附件到24楼  发现您这段代码也是有bug的  您有空帮看看。谢谢

longwin

Sub testbylongwin()
    Arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    For i = 3 To UBound(Arr)
        If Not d.exists(Arr(i, 1)) Then
            d(Arr(i, 1)) = Arr(i, 2)
        Else
            d(Arr(i, 1)) = d(Arr(i, 1)) & "/" & Arr(i, 2)
        End If
    Next
    For Each k In d.keys
        d1.RemoveAll
        If InStr(1, d(k), "/") > 0 Then
            brr = Split(d(k), "/")
            For j = 0 To UBound(brr)
                d1(brr(j)) = 1
            Next
            d(k) = Join(d1.keys, "/")
        End If
    Next
    [d3].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    Set d = Nothing
    Set d1 = Nothing
End Sub

jerry3770

longwin 发表于 2024-7-30 16:36
Sub testbylongwin()
    Arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
...

谢谢老师指导  结果正确  这个我看得明白了  我就学习这篇了   加分！！！鼓掌