表格多列转换1列

表格大神

求大神将附件数据源转换成需求结果形式，虽然透视可实现，这个也能用公式来实现=TEXTJOIN(CHAR(10),,A2:A6) ， 一但数据多也是需要手工操作的，有什么简单快捷的VBA？谢谢~

iu950

学习时间占比不到30%，凌晨4点钟还没睡

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, br, i&, r&, dic As Object, vKey
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
    For i = 3 To UBound(ar) - 1: dic(ar(i, 3)) = "": Next
   
    ReDim br(1 To UBound(ar), 1 To 3)
    For Each vKey In dic.keys
        r = r + 1: br(r, 1) = vKey
        For i = 3 To UBound(ar)
            If ar(i, 3) = vKey Then
                 br(r, 2) = br(r, 2) + ar(i, 5)
                 br(r, 3) = br(r, 3) & vbLf & ar(i, 2) & ar(i, 4)
            End If
        Next i
        br(r, 3) = Mid(br(r, 3), 2)
    Next
   
    [G3].Resize(r, 3) = br
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

请楼主参考附件。。。

旁观者？

Type mytype
      x As String
      y As Single
End Type
Sub TEST2()
    Dim k As Integer, i As Integer
    Dim dic As Object
    Dim ar, br
Dim a(100) As mytype

k = 0
Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
    For i = 3 To UBound(ar) - 1
        If dic.Exists(ar(i, 3)) Then
        a(dic(ar(i, 3))).x = a(dic(ar(i, 3))).x & vbLf & ar(i, 2) & ar(i, 4)
        a(dic(ar(i, 3))).y = a(dic(ar(i, 3))).y + ar(i, 5)
        Else
        
        dic(ar(i, 3)) = k
        a(k).x = ar(i, 2) & ar(i, 4)
        a(k).y = ar(i, 5)
        k = k + 1
        End If
        
    Next
ReDim br(1 To dic.Count, 1 To 3)

For Each Key In dic.keys
    br(dic(Key) + 1, 1) = Key
    br(dic(Key) + 1, 2) = a(dic(Key)).y
    br(dic(Key) + 1, 3) = a(dic(Key)).x
Next

     [G3].Resize(dic.Count, 3) = br
     Set dic = Nothing
   
End Sub

旁观者？

Sub TEST1()
    Dim k As Integer, i As Integer
    Dim dic As Object
    Dim ar, br()

k = 0
Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
    For i = 3 To UBound(ar) - 1
        If dic.Exists(ar(i, 3)) Then
        br(3, dic(ar(i, 3))) = br(3, dic(ar(i, 3))) & vbLf & ar(i, 2) & ar(i, 4)
        br(2, dic(ar(i, 3))) = br(2, dic(ar(i, 3))) + ar(i, 5)
        Else
        ReDim Preserve br(1 To 3, 1 To k + 1)
        dic(ar(i, 3)) = k + 1
        br(1, k + 1) = ar(i, 3)
        br(3, k + 1) = ar(i, 2) & ar(i, 4)
        br(2, k + 1) = ar(i, 5)
        k = k + 1
        End If
        
    Next

     [G3].Resize(dic.Count, 3) = Application.Transpose(br)
     Set dic = Nothing
   
End Sub

cjc209

我看了一下 代码都偏多 我来个少点的
Sub 测试()
    arr = Sheet1.[a3:e8]
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        关键字 = arr(i, 3) & ""
        If Not dic.Exists(关键字) Then
            dic(关键字) = Array(arr(i, 5), arr(i, 2) & arr(i, 4))
        Else
            dic(关键字) = Array(dic(关键字)(0) + arr(i, 5), dic(关键字)(1) & vbNewLine & arr(i, 2) & arr(i, 4))
        End If
    Next
    keysarr = dic.keys
    itemarr = dic.items
    For i = 0 To UBound(keysarr)
        Cells(i + 3, 12) = keysarr(i)
        Cells(i + 3, 13) = itemarr(i)(0)
        Cells(i + 3, 14) = itemarr(i)(1)
    Next
End Sub

准提部林

字典//撿拾器

Sub TEST_A1()
Dim Arr, xD, i&, T$, V, X$, R&, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([e1], Cells(Rows.Count, 1).End(3))
For i = 3 To UBound(Arr) - 1
    T = Arr(i, 3): V = Arr(i, 5): X = Arr(i, 2) & Arr(i, 4)
    If xD(T) = 0 Then
       N = N + 1: xD(T) = N
       Arr(N, 1) = T: Arr(N, 2) = V: Arr(N, 3) = X
    Else
       Arr(xD(T), 2) = Arr(xD(T), 2) + V
       Arr(xD(T), 3) = Arr(xD(T), 3) & Chr(10) & X
    End If
i01: Next i
[g3].Resize(N, 3) = Arr
End Sub

mmwwdd

mmwwdd

弄的太复杂，字典带数组就行，越简单越好