­ã´£³¡ªL

°Ñ¦Ò:
http://forum.twbts.com/thread-22063-1-2.html

À³¸Ó¬O transpose ¶W­­°ÝÃD

­ã´£³¡ªL

¦^´_ 3# jesscc


³o¤å¦rªø«×¦p¦óÅýtranspose²£¥Í¿ù»~, §Ú¤]¤£²M·¡, ¾¨¶q¤£¥Î~~

'­^¤å«~¶µ¦X¨Ö
Dim Brr, N&, U&, TS$
Set d1 = CreateObject("Scripting.Dictionary")
ReDim Brr(1 To [T300].End(xlUp).Row, 0) '©w¸q¤@­Ó°}¦C[®e¯Ç¾¹]
For Each T In Range([T7], [T300].End(xlUp))
If T(1, 3) = "" Or T(1, -4) = "" Then GoTo AA 'T®æ©Î­^¤å«~¶µ¬°ªÅ--²¤¹L
   TS = T(1, -4) & " " & T(1, 3) & " " & T(1, -2) '¸Ó¦æ¦ê±µ¤å¦r
   U = d1(T & "") '¨ú±o¦r¨åÀɬÛÀ³ªº[§Ç¸¹]
   If U > 0 Then Brr(U, 0) = Brr(U, 0) & "," & TS:   GoTo AA '¦pªG§Ç¸¹¤j¤_0, ¶i¦æ²Ä2µ§¥H«áªº¦ê±µ
   N = N + 1:   d1(T & "") = N:   Brr(N, 0) = TS '¦pªG§Ç¸¹¬°0, §Ç¸¹»¼¼W1¦s¤J¦r¨åÀÉ, ¶ñ¤J²Ä¤@­Ó¤å¦r¦ê
AA: Next
[AG7].Resize(N, 1) = Brr


==========================

­ã´£³¡ªL

¦^´_ 6# jesscc

'¤¤¤å«~¶µ¦X¨Ö
Set d = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
   If d(T.Value) = "" Then
      d(T.Value) = T.Offset(, -6) & " " & T.Offset(, -4) & " " & T.Offset(, -3)
      Else
      d(T.Value) = d(T.Value) & ", " & T.Offset(, -6) & " " & T.Offset(, -4) & " " & T.Offset(, -3)

    End If
Next
ReDim Arr(1 To d.Count, 0), Brr(1 To d.Count, 0)
For Each k In d.keys
    N = N + 1: Arr(N, 0) = k: Brr(N, 0) = d(k)
Next
[Y7].Resize(N, 1) = Arr
[AF7].Resize(N, 1) = Brr

'=========================================
'­^¤å«~¶µ¦X¨Ö
Set d1 = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
If T.Offset(, 2) = "" Then GoTo AA
   If d1(T.Value) = "" Then
      d1(T.Value) = T.Offset(, -5) & " " & T.Offset(, 2) & " " & T.Offset(, -3)
      Else
      d1(T.Value) = d1(T.Value) & ", " & T.Offset(, -5) & " " & T.Offset(, 2) & " " & T.Offset(, -3)
    End If
AA: Next
N = 0: ReDim Arr(1 To d1.Count, 0)
For Each k In d1.items
    N = N + 1: Arr(N, 0) = k
Next
[AG7].Resize(N, 1) = Arr


±N¦r¨åÀɦA°µ¤@¦¸«á¸m³B²z, ¯Ç¤J°}¦C§Y¥i~~

===============================

­ã´£³¡ªL

¦^´_ 6# jesscc

¨âºØ¦X¨Ö¤@¦¸°j°é§¹¦¨:
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
   If d(T & "") = "" Then
      d(T & "") = T(, -5) & " " & T(, -3) & " " & T(, -2)
      d1(T & "") = T(, -4) & " " & T(, 3) & " " & T(, -2)
   Else
      d(T & "") = d(T & "") & ", " & T(, -5) & " " & T(, -3) & " " & T(, -2)
      d1(T & "") = d1(T & "") & ", " & T(, -4) & " " & T(, 3) & " " & T(, -2)
    End If
Next
ReDim Arr(1 To d.Count, 0), Brr(1 To d.Count, 1 To 2)
For Each k In d.keys
    N = N + 1
    Arr(N, 0) = k
    Brr(N, 1) = d(k)
    Brr(N, 2) = d1(k)
Next
[Y7].Resize(N, 1) = Arr
[AF7].Resize(N, 2) = Brr

=======================================

­ã´£³¡ªL

¦^´_ 6# jesscc

¥HÅܼƥN´À¤å¦r¦ê, ÁקK¦h¦¸¤Þ¥ÎÀx¦s®æ, ¥i´£¤É®Ä²v,
¦P®É, ­Y¶·§ó§ï, ¥u­n­×§ï¤@­Ó¦a¤è§Y¥i~~
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For Each T In Range([T7], [T300].End(xlUp))
    s1$ = T(, -5) & " " & T(, -3) & " " & T(, -2)
    s2$ = T(, -4) & " " & T(, 3) & " " & T(, -2)
    If d(T & "") = "" Then
       d(T & "") = s1
       d1(T & "") = s2
    Else
       d(T & "") = d(T & "") & ", " & s1
       d1(T & "") = d1(T & "") & ", " & s2
    End If
Next
ReDim Arr(1 To d.Count, 0), Brr(1 To d.Count, 1 To 2)
For Each k In d.keys
    N = N + 1
    Arr(N, 0) = k
    Brr(N, 1) = d(k)
    Brr(N, 2) = d1(k)
Next
[Y7].Resize(N, 1) = Arr
[AF7].Resize(N, 2) = Brr

=======================================

­ã´£³¡ªL

¦^´_ 10# jesscc

¨º¬O T.cells(?, ?) ªº¥Îªk,
·í®æ T(1,1)
¥k¤@®æ T(1,2)
¥ª¤@®æ T(1,0)

­ã´£³¡ªL

¦^´_ 13# jesscc

Sub A_To_B()
Dim mRow&, Crr, Y As Range, YR, C%
Set d = CreateObject("scripting.dictionary")
mRow = Sheets("¤u§@ªí2").[B500].End(xlUp).Row + 1
For Each Y In Range([Y7], [Y300].End(3))
d(Y & "") = Array(Y.Offset(, -1), Y, Y.Offset(, 6), Y.Offset(, 8), "", Y, "PKG", Y.Offset(, -1), Y.Offset(, 7), "", Y.Offset(, 3) / Y.Offset(, -1), Y.Offset(, 3), Y.Offset(, 4), Y.Offset(, 5))
If C = 0 Then C = UBound(d(Y & "")) + 1
Next

N = 0
¦r¨åÀɪºitem¬O°}¦C, ¥²¶·³v¤@½Õ¥Î
ReDim Crr(1 To d.Count, 1 To C)
For Each k In d.keys
    N = N + 1
    YR = d(k & "")
    For j = 1 To C: Crr(N, j) = YR(j - 1): Next
Next
With Sheets("¤u§@ªí2")
     .Range("B" & mRow).Resize(N, C).Value = Crr 'range«e¤Ö¤@­Ó "."
     .Activate
End With
End Sub

============================