Board logo

標題: [發問] 資料直向轉橫向排列 [打印本頁]
作者: Genie    時間: 2013-1-7 11:30     標題: 資料直向轉橫向排列

不好意思又來詢問了

我從資料庫抓出來的資料如附件的"原始資料"所示　呈現的是直向排列
若我要將資料轉變成附件中"轉置後"的樣子
不知是否有辦法達到？

因為我抓出來的資料列數都達到上萬筆
所以是希望能在新的 sheet 做轉置　順便保留原始資料可以做參考

若以 A 欄來當作群組作轉置　則 A 欄的"1"、"2"、"3"各分別為一群組
標題就以"1"、"2"、"3"當作標題
若以 B 欄來當作群組作轉置　則 B 欄的"4"、"5"、"6"再搭配 A 欄的"1"、"2"、"3"作為一群組
標題就以"A-B"來當作標題　因此標題就是"1-4"、"1-5"、"1-6"、"2-4"、2-5"、"2-6"、"3-4"、"3-5"、"3-6"

希望可以幫幫我　謝謝∼

[attach]13826[/attach]
作者: mark15jill    時間: 2013-1-7 15:06

回復 1# Genie
比較基礎的寫法
  1. Sub oag()

  3. Range("g2:az20000").Clear  '此行可刪除 主要是用來清除多餘重複的

  5. For uua = 1 To 3
  6.     For uub = 4 To 6
  7.             For uud = 2 To Range("a2").CurrentRegion.Rows.Count
  8.                 Select Case uua
  9.                     Case 1
  10.                     If Cells(uud, 1) = uua Then Cells(uud, uua + 22) = Cells(uud, 3)
  11.                     Select Case uub
  12.                         Case uub
  13.                         If Cells(uud, 1) = uua And Cells(uud, 2) = uub Then Cells(uud, uua + 21 + uub) = Cells(uud, 3)
  14.                     End Select
  15.                
  16.                     Case 2
  17.                     If Cells(uud, 1) = uua Then Cells(uud, uua + 22) = Cells(uud, 3)

  19.                     Select Case uub
  20.                         Case uub
  21.                         If Cells(uud, 1) = uua And Cells(uud, 2) = uub Then Cells(uud, uua + 23 + uub) = Cells(uud, 3)
  22.                     End Select
  23.                     Case 3
  24.                     If Cells(uud, 1) = uua Then Cells(uud, uua + 22) = Cells(uud, 3)
  25.                     Select Case uub
  26.                         Case uub
  27.                         If Cells(uud, 1) = uua And Cells(uud, 2) = uub Then Cells(uud, uua + 25 + uub) = Cells(uud, 3)
  28.                     End Select
  29.                 End Select
  30.             Next
  31.     Next
  32. Next
  33. For aaa = 1 To Range("a2").CurrentRegion.Rows.Count
  34.     For uus = 23 To 34
  35.         For uuk = 2 To Range("a2").CurrentRegion.Rows.Count
  36.             If Cells(2, uus) = "" Then
  37.                 Cells(2, uus).Select
  38.                 Selection.Delete Shift:=xlUp
  39.             End If
  40.         Next
  41.     Next
  42. Next

  44. End Sub
複製代碼
作者: GBKEE    時間: 2013-1-7 17:46

本帖最後由 GBKEE 於 2013-1-7 18:38 編輯

回復 1# Genie
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D(1 To 2) As Object, AR(), Rng As Range, i As Integer, K As Variant
  4.     Set D(1) = CreateObject("SCRIPTING.DICTIONARY")   '字典物件
  5.     Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
  6.     Set Rng = Sheets("原始資料").Range("a2")          '儲存格物件
  7.     Do
  8.         '1. 依照 A 欄作區分，將資料由直向排列變為橫向排列。
  9.         '2. 若依 A 欄作區分，就以 A 欄的值作為標題。
  10.         If D(1).exists(Rng.Value) Then                      '字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
  11.            AR = D(1)(Rng.Value)                             '陣列=字典物件(關鍵字)的內容
  12.            ReDim Preserve AR(UBound(D(1)(Rng.Value)) + 1)   '陣列擴充增加一元素
  13.            AR(UBound(AR)) = Rng.Cells(1, 3).Value           '陣列增加的元素=C欄的數值
  14.            D(1)(Rng.Value) = AR                             '字典物件(關鍵字)的內容=陣列
  15.         Else
  16.             D(1)(Rng.Value) = Array(Rng.Cells(1, 3).Value)  '字典物件(關鍵字)的內容=陣列
  17.         End If
  18.         '*********************************************
  19.         '1. 依照 B 欄作區分，將資料由直向排列變為橫向排列。
  20.         '2. 若依 B 欄作區分，就以 A-B 欄的值作為標題
  21.         K = "'" & Rng & " - " & Rng.Cells(1, 2)
  22.         If D(2).exists(K) Then
  23.            AR = D(2)(K)
  24.            ReDim Preserve AR(UBound(D(2)(K)) + 1)
  25.            AR(UBound(AR)) = Rng.Cells(1, 3).Value
  26.            D(2)(K) = AR
  27.         Else
  28.             D(2)(K) = Array(Rng.Cells(, 3).Value)
  29.         End If
  30.         Set Rng = Rng.Offset(1)
  31.     Loop Until Rng = ""
  32.     With Sheets("sheet1")
  33.         .Cells.Clear
  34.         If D(1).Count > 0 Then
  35.             i = 1
  36.             For Each K In D(1).keys    'K= 字典物件(關鍵字)
  37.                 .Cells(1, i) = K
  38.                 .Cells(2, i).Resize(UBound(D(1)(K)) + 1) = Application.WorksheetFunction.Transpose(D(1)(K))  '讀取內容
  39.                 i = i + 1
  40.             Next
  41.         End If
  42.         If D(2).Count > 0 Then
  43.             i = 10
  44.             For Each K In D(2).keys
  45.                 .Cells(1, i) = K
  46.                 .Cells(2, i).Resize(UBound(D(2)(K)) + 1) = Application.WorksheetFunction.Transpose(D(2)(K))
  47.                 i = i + 1
  48.             Next
  49.         End If
  50.     End With
  51. End Sub
複製代碼
作者: Genie    時間: 2013-1-7 17:49

回復 2# mark15jill


謝謝∼
不過雖然可以成功做出來　但因我的資料量很龐大
執行起來速度非常慢　不知是否有改善方法？
而且我一次只會選擇一欄 (A 欄或 B 欄) 來做分組
並不需要一次就將選擇兩欄的情況執行出來
另外　資料每次轉置後的欄位可到三、四十欄
所以我希望能在新 sheet 執行轉置後的結果
請問有辦法嗎？
作者: Genie    時間: 2013-1-7 18:00

回復 3# GBKEE


謝謝∼　成功做出我想要的資料格式了！！！
不過我一次只會選擇一欄 (A 欄或 B 欄) 來做分組
並不需要一次就將選擇兩欄的情況執行出來
所以是否有辦法讓我一開始就選擇要使用 A 欄或 B 欄來做分組轉置我的資料呢？
作者: GBKEE    時間: 2013-1-7 18:38

回復 5# Genie
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D As Object, AR(), Rng As Range, i As Integer, K As Variant, W As String
  4.     Do
  5.         W = InputBox("請選擇: A 欄作區分 或 B 欄作區分")
  6.         If W = "" Then Exit Sub                         '沒輸入:離開程式
  7.     Loop Until UCase(W) = "A" Or UCase(W) = "B"
  8.     Set D = CreateObject("SCRIPTING.DICTIONARY")        '字典物件
  9.     Set Rng = Sheets("原始資料").Range("a2")            '儲存格物件
  10.     Do
  11.         If UCase(W) = "A" Then K = Rng.Value
  12.         If UCase(W) = "B" Then K = "'" & Rng & " - " & Rng.Cells(1, 2)
  13.         If D.exists(K) Then                             '字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
  14.             AR = D(K)                                   '陣列=字典物件(關鍵字)的內容
  15.             ReDim Preserve AR(UBound(D(K)) + 1)         '陣列擴充增加一元素
  16.             AR(UBound(AR)) = Rng.Cells(1, 3).Value      '陣列增加的元素=C欄的數值
  17.             D(K) = AR                                   '字典物件(關鍵字)的內容=陣列
  18.         Else
  19.             D(K) = Array(Rng.Cells(1, 3).Value)         '字典物件(關鍵字)的內容=陣列
  20.         End If
  21.         Set Rng = Rng.Offset(1)
  22.     Loop Until Rng = ""
  23.     With Sheets("轉置後")
  24.         .Cells.Clear
  25.         If D.Count > 0 Then
  26.             i = 1
  27.             For Each K In D.keys    'K= 字典物件(關鍵字)
  28.                 .Cells(1, i) = K
  29.                 .Cells(2, i).Resize(UBound(D(K)) + 1) = Application.WorksheetFunction.Transpose(D(K))  '讀取內容
  30.                 i = i + 1
  31.             Next
  32.         End If
  33.     End With
  34. End Sub
複製代碼
作者: c_c_lai    時間: 2013-1-8 07:26

本帖最後由 c_c_lai 於 2013-1-8 07:27 編輯

回復 6# GBKEE
回復 5# Genie
GBKEE 版大早安！
今早讀了 "資料直向轉橫向排列" 發覺 Idea 不錯，於是乎
除了原先的  "A欄、B 欄" ，我又加入了 "AB 欄" 選項。
來取樂一下，請勿見怪！(我另增加一工作表單 "測試結果")
  1. Sub Ex2()
  2.     Dim D As Object, AR(), Rng As Range, i As Integer, K As Variant, W As String
  3.     Dim cts As Integer, nums As Integer
  4.    
  5.     '  Do
  6.     '      W = InputBox("請選擇: A 欄作區分 或 B 欄作區分")
  7.     '      If W = "" Then Exit Sub                         '  沒輸入:離開程式
  8.     '  Loop Until UCase(W) = "A" Or UCase(W) = "B"
  9.     W = InputBox("請選擇: A 欄作區分 或 B 欄作區分、" & vbCrLf & "亦或是 AB 欄作區分")
  10.     If UCase(W) <> "A" And UCase(W) <> "B" And UCase(W) <> "AB" Then Exit Sub   '  沒輸入:離開程式
  11.    
  12.     nums = IIf(UCase(W) = "AB", 2, 1)
  13.     Set D = CreateObject("Scripting.Dictionary")            '  字典物件
  14.    
  15.     For cts = 1 To nums
  16.         Set Rng = Sheets("原始資料").Range("a2")            '  儲存格物件
  17.         
  18.         Do
  19.            If UCase(W) = "AB" Then
  20.                 K = IIf(cts = 1, Rng.Value, "'" & Rng & " - " & Rng.Cells(1, 2))
  21.             Else
  22.                 K = IIf(UCase(W) = "A", Rng.Value, "'" & Rng & " - " & Rng.Cells(1, 2))
  23.             End If
  24.                
  25.             If D.exists(K) Then                             '  字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
  26.                 AR = D(K)                                   '  陣列=字典物件(關鍵字)的內容
  27.                 ReDim Preserve AR(UBound(D(K)) + 1)         '  陣列擴充增加一元素
  28.                 AR(UBound(AR)) = Rng.Cells(1, 3).Value      '  陣列增加的元素=C欄的數值
  29.                 D(K) = AR                                   '  字典物件(關鍵字)的內容=陣列
  30.             Else
  31.                 D(K) = Array(Rng.Cells(1, 3).Value)         '  字典物件(關鍵字)的內容=陣列
  32.             End If
  33.             Set Rng = Rng.Offset(1)
  34.         Loop Until Rng = ""
  35.     Next
  36.             
  37.     With Sheets("測試結果")
  38.         .Cells.Clear
  39.             
  40.         If D.Count > 0 Then
  41.             i = 1
  42.             For Each K In D.keys                            '  K = 字典物件(關鍵字)
  43.                 .Cells(1, i) = K
  44.                 .Cells(2, i).Resize(UBound(D(K)) + 1) = Application.WorksheetFunction.Transpose(D(K))  '  讀取內容
  45.                 i = i + 1
  46.             Next
  47.         End If
  48.     End With
  49. End Sub
複製代碼
作者: Hsieh    時間: 2013-1-8 09:11

回復 1# Genie
  1. Sub ex()
  2. Dim A As Range, d As Object, j&, i%, s%, C$, Ky
  3. C = InputBox("輸入欄位A或B", , "A")
  4. Set d = CreateObject("Scripting.Dictionary")
  5. With Sheet1
  6. j = 2
  7. Do Until .Cells(j, 1) = ""
  8.   Set A = .Cells(j, C)
  9.   s = Application.CountIf(.Range(A, A.End(xlDown)), A)
  10.   i = Application.CountIf(A.Resize(s, 1), .Cells(j, C)) '計算單筆資料量
  11.   If C = "A" Then
  12.      d(A.Value) = A.Offset(, 2).Resize(i, 1).Value
  13.      Else
  14.      d(A.Offset(, -1) & "_" & A) = A.Offset(, 1).Resize(i, 1).Value
  15.   End If
  16. j = j + i
  17. Loop
  18. End With
  19. With Sheet2
  20. .UsedRange.Clear
  21. k = 1
  22. For Each Ky In d.keys
  23.    .Cells(1, k) = Ky
  24.    .Cells(2, k).Resize(i, 1) = d(Ky)
  25.    k = k + 1
  26. Next
  27. End With
  28. End Sub
複製代碼
作者: Genie    時間: 2013-1-8 13:57

回復 6# GBKEE
回復 7# c_c_lai


謝謝∼　程式執行起來沒有問題！！！

再請問　若我要擴充欄位　用 C 欄或 D 欄作區分
有辦法小改這個程式就做得到嗎？

雖然目前用不到　但想了解未來有需要時我可以怎樣做改寫
謝謝∼
作者: Genie    時間: 2013-1-8 14:16

回復 8# Hsieh


這個程式執行起來　有幾個數據會無法轉置成功
且會出現 ＃N/A 的欄位
如圖是選 A 欄進行轉置
在 "1" 欄中少了一個數據　在 "2" 欄中多了 #N/A
請問有辦法改善嗎？
謝謝∼
[attach]13843[/attach]
作者: Hsieh    時間: 2013-1-8 14:51

回復 10# Genie
資料會有每欄不同資料量嗎?
試試寫入時依各群組資料量寫入
  1. Sub ex()

  3. Dim A As Range, d As Object, j&, i%, s%, C$, Ky

  5. C = InputBox("輸入欄位A或B", , "A")

  7. Set d = CreateObject("Scripting.Dictionary")

  9. With Sheet1

  11. j = 2

  13. Do Until .Cells(j, 1) = ""

  15.   Set A = .Cells(j, C)

  17.   s = Application.CountIf(.Range(A, A.End(xlDown)), A)

  19.   i = Application.CountIf(A.Resize(s, 1), .Cells(j, C)) '計算單筆資料量

  21.   If C = "A" Then

  23.      d(A.Value) = A.Offset(, 2).Resize(i, 1).Value

  25.      Else

  27.      d(A.Offset(, -1) & "_" & A) = A.Offset(, 1).Resize(i, 1).Value

  29.   End If

  31. j = j + i

  33. Loop

  35. End With

  37. With Sheet2

  39. .UsedRange.Clear

  41. k = 1

  43. For Each Ky In d.keys

  45.    .Cells(1, k) = Ky

  47.    .Cells(2, k).Resize(UBound(d(Ky)), 1) = d(Ky)

  49.    k = k + 1

  51. Next

  53. End With

  55. End Sub
複製代碼
作者: softsadwind    時間: 2013-1-8 16:14

回復 10# Genie


    我測試起來的結果是ok的說....
    [attach]13845[/attach]

另外一個問題要請教各位大大
當d1 的item過多的時候
.[A2].Resize(d1.Count, 6) = Application.Transpose(Application.Transpose(d1.items))
他在轉換的時候就會出現型態不符
[attach]13846[/attach]

嘗試把row 改在 500之內，就可以直接.[A2].Resize(d1.Count, 6) = Application.Transpose(Application.Transpose(d1.items))

只好用別的方式處理
    For Each E In D.items
        
           E.Copy Sheets("Last - N").Range("A" & Rows.Count).End(xlUp).Offset(1)
        
    Next

不知道有人可以指點更方便的方式嗎？
作者: Genie    時間: 2013-1-8 16:32

回復 11# Hsieh


沒錯！　資料量每欄都不同
不過這個程式解決了這個問題
非常謝謝∼
作者: Genie    時間: 2013-1-8 16:37

回復 12# softsadwind


一開始 Hsieh 超級版主提供的程式執行起來會有一點問題
執行出來的結果可以去比對原始資料　會發現有幾個數值是沒有轉置成功的！
作者: c_c_lai    時間: 2013-1-8 17:56

回復 11# Hsieh
回復 14# Genie
Hsieh 版大新年愉快！
經測試發現有點小瑕玼，修改了一點
  1. '  s = Application.CountIf(.Range(A, A.End(xlDown)), A)
  2. s = Application.CountIf(.Range("A" & j, .[A2].End(xlDown)), .Cells(j, "A"))
複製代碼
過程如附圖：
[attach]13849[/attach]
作者: Andy2483    時間: 2023-4-13 16:15

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請前輩們指教

執行前:
[attach]36126[/attach]

輸入窗輸入"A":
[attach]36127[/attach]

輸入窗輸入"B":
[attach]36128[/attach]


Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 1), A, Y, strNo1, R&, C%, i&, T1$, T2$, T3$, TT$
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
strNo1 = InputBox("輸入欄位A或B", , "A")
If StrPtr(strNo1) = 0 Or InStr("/A/B/", "/" & strNo1 & "/") = 0 Then Exit Sub
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("原始資料"): Set xR = Sh1.[A1].CurrentRegion: Brr = xR
Set Sh2 = Sheets("轉置後"): Sh2.UsedRange.Clear
For i = 2 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3)
   TT = Switch(strNo1 = "A", T1, strNo1 = "B", T1 & "-" & T2)
   A = Y(TT)
   If Not IsArray(A) Then A = Crr: C = C + 1: Y(TT & "|c") = C
   R = Y(TT & "|r"): R = R + 1: Y(TT & "|r") = R
   A(R, 1) = T3
   Y(TT) = A
Next
For Each A In Y.keys
   If IsArray(Y(A)) Then
      Sh2.Cells(1, Y(A & "|c")) = "'" & A
      Sh2.Cells(2, Y(A & "|c")).Resize(Y(A & "|r"), 1) = Y(A)
   End If
Next
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)