一维转二维

yshcy

AB两列是数据源，D-G是代码运行结果。但是这个代码把部门写死了，请问如何改进，谢谢。

taller

3190496160

Sub 转换()
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .[a1].Resize(r, 2)
    For i = 2 To UBound(ar)
        If ar(i, 1) <> Empty Then
            If Not d.exists(ar(i, 1)) Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
            d(ar(i, 1))(i) = ar(i, 2)
        End If
    Next i
    ReDim br(1 To UBound(ar), 1 To UBound(ar))
    For Each k In d.keys
        m = 1
        n = n + 1
        br(n, 1) = k
        For Each kk In d(k).items
            m = m + 1
            br(n, m) = kk
        Next kk
    Next k
    .[d2].Resize(n, UBound(br, 2)) = br
End With
Set d = Nothing
MsgBox "ok!"
End Sub

3190496160

ynzsvt

1. Sub 转换2()
   
2. Dim Arr As Variant, i&
   
3. Dim Brr()
   
4. Dim Dic部门 As Object, Dic姓名 As Object, Di
   
5. Set Dic部门 = CreateObject("Scripting.Dictionary")
   
6. Set Dic姓名 = CreateObject("Scripting.Dictionary")
   
7. With ActiveSheet
   
8.   i = .Cells(Rows.Count, 1).End(xlUp).Row
   
9.   Arr = .[a1].Resize(i, 2)
   
10.   ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr))
    
11.   For i = 2 To UBound(Arr)
    
12.    If Arr(i, 1) <> Empty Then
    
13.     If Not Dic部门.Exists(Arr(i, 1)) Then Dic部门(Arr(i, 1)) = Dic部门.Count + 1 _
    
14.       : Brr(Dic部门(Arr(i, 1)), 1) = Arr(i, 1)
    
15.     Dic姓名(Arr(i, 1)) = Dic姓名(Arr(i, 1)) + 1
    
16.     Brr(Dic部门(Arr(i, 1)), Dic姓名(Arr(i, 1)) + 1) = Arr(i, 2)
    
17.    End If
    
18.   Next i
    
19. 
    
20.   Di = Dic姓名.Items
    
21.   i = Application.WorksheetFunction.Max(Di) + 1
    
22.   .[d2].Resize(Dic部门.Count, i) = Brr
    
23. End With
    
24. Set Dic部门 = Nothing
    
25. Set Dic姓名 = Nothing
    
26. MsgBox "ok!"
    
27. End Sub

复制代码

今铭昔

wang-way

比比可读性

Qs18

Sub 一维转二维()
    Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        Dim arr: arr = .Range("a1").CurrentRegion.Value
        For i = 2 To UBound(arr)
            s = arr(i, 1)
            If Not dic.exists(s) Then
                dic(s) = arr(i, 2)
            Else
                dic(s) = dic(s) & "|" & arr(i, 2)
            End If
        Next
        m = 1
        cl = 4
        For Each k In dic.keys
            m = m + 1
            .Cells(m, cl) = k
            t = Split(dic(k), "|")
            For j = LBound(t) To UBound(t)
                cl = cl + 1
                .Cells(m, cl).Value = t(j)
            Next
            cl = 4
        Next
    End With
    MsgBox "完成！"
End Sub

Qs18

试试..........

Qs18

试一下.......