【已解决】字典初学求助大佬点拨下！谢谢！（万分感谢各位大佬）

约定的童话

自己试着写了一下代码，也查了一些资料，还是没有研究出来，主要想实现图片上的效果！目前代码实现不了，第三列那里不会写了....

Moneky

1. Sub test()
   
2.     Dim i As Long, arr, t As String, d As Object
   
3.     arr = [a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         t = arr(i, 1) & " " & arr(i, 2)
   
7.         If d.exists(t) Then
   
8.             d(t) = d(t) & " " & arr(i, 3)
   
9.         Else
   
10.             d(t) = arr(i, 3)
    
11.         End If
    
12.     Next
    
13.     [i:i].Clear
    
14.     [h1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
15.     [j1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
    
16.     [h:h].TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
    
17.         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    
18.         Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    
19.         :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    
20. End Sub
    

复制代码

liuxi001

~~~~~~~~~~~~~~~~~~~~~

Moneky

wj2368

只差了一步。。。。。

liuxi001

if not d.exists(t) then
  d(t)=d.count+1
  n=d(t)
  brr(n,1)=arr(i,1)
  brr(n,2)=arr(i,2)
  brr(n,3)=arr(i,3)
else
  n=d(t)
  brr(n,3)=brr(n,3) & " " & arr(i,3)
endif

micch

如果人名都是相同的，那就直接用日期做key，加入字典就行了
如果日期不是乱序，那不用字典，只需要数组循环就行了

donghui2363

        If Not d.exists(t) Then
            n = n + 1
            d(t) = n
            If n <> i Then
                brr(n, 1) = arr(i, 1)
                brr(n, 2) = arr(i, 2)
                'brr(n, 3) = d(arr(i, 3)) & " " & arr(i, 3)
            End If
        End If
        brr(n, 3) = brr(n, 3) & " " & arr(i, 3) '写到这里可以吗
     Next
    [h1].Resize(UBound(brr), 3) = brr
End Sub

wj2368

donghui2363 发表于 2019-6-13 10:56
If Not d.exists(t) Then
            n = n + 1
            d(t) = n

If Not d.exists(t) Then
            n = n + 1
            d(t) = n
                brr(n, 1) = arr(i, 1)
                brr(n, 2) = arr(i, 2)
                brr(n, 3) = arr(i, 3)
            ELSE
                brr( d(t) , 3) = brr( d(t) , 3)& " " & arr(i, 3)
            End If      
     Next
    [h1].Resize(UBound(brr), 3) = brr
这样写才对

abc123281

Sub test()
Dim i, n, arr, brr(), d As Object, t
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
  t = arr(i, 1) & arr(i, 2)
  If Not d.exists(t) Then
    n = n + 1
    d(t) = n
    For j = 1 To 3
      brr(n, j) = arr(i, j)
    Next
  Else
    m = d(t)
    brr(m, 3) = brr(m, 3) & "," & arr(i, 3)
  End If
Next
[h1].Resize(n, 3) = brr
End Sub