返回列表 上一主題 發帖

[發問] 資料直向轉橫向排列

[發問] 資料直向轉橫向排列

不好意思又來詢問了

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

因為我抓出來的資料列數都達到上萬筆
所以是希望能在新的 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"

希望可以幫幫我 謝謝∼

資料.zip (4.42 KB)

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

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

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

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

  40. End Sub
複製代碼

  多做多想多學習,少看少錯少迷途

  多做=多多練習,多多編寫。
  多想=想想為什麼人家程式要那樣寫,如果換成自己,又會怎寫。
  多學習=學習人家的發問並解答,學習人家的寫法

  少看=只看不做也枉然

TOP

本帖最後由 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
複製代碼

TOP

回復 2# mark15jill


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

TOP

回復 3# GBKEE


謝謝∼ 成功做出我想要的資料格式了!!!
不過我一次只會選擇一欄 (A 欄或 B 欄) 來做分組
並不需要一次就將選擇兩欄的情況執行出來
所以是否有辦法讓我一開始就選擇要使用 A 欄或 B 欄來做分組轉置我的資料呢?

TOP

回復 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
複製代碼

TOP

本帖最後由 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
複製代碼

TOP

回復 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
複製代碼
學海無涯_不恥下問

TOP

回復 6# GBKEE
回復 7# c_c_lai


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

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

雖然目前用不到 但想了解未來有需要時我可以怎樣做改寫
謝謝∼

TOP

回復 8# Hsieh


這個程式執行起來 有幾個數據會無法轉置成功
且會出現 #N/A 的欄位
如圖是選 A 欄進行轉置
在 "1" 欄中少了一個數據 在 "2" 欄中多了 #N/A
請問有辦法改善嗎?
謝謝∼
執行結果.JPG
2013-1-8 14:16

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
返回列表 上一主題