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

Genie

不好意思又來詢問了

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

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

下載次數: 35

2013-1-7 11:30

mark15jill

回復 1# Genie
比較基礎的寫法

1. Sub oag()
   
2. 
   
3. Range("g2:az20000").Clear  '此行可刪除 主要是用來清除多餘重複的
   
4. 
   
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)
    
18. 
    
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
    
43. 
    
44. End Sub

複製代碼

GBKEE

回復 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

回復 2# mark15jill


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

Genie

回復 3# GBKEE


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

GBKEE

回復 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

回復 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

回復 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

回復 6# GBKEE
回復 7# c_c_lai


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

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

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

Genie

回復 8# Hsieh


這個程式執行起來　有幾個數據會無法轉置成功
且會出現 ＃N/A 的欄位
如圖是選 A 欄進行轉置
在 "1" 欄中少了一個數據　在 "2" 欄中多了 #N/A
請問有辦法改善嗎？
謝謝～

下載 (37.81 KB)

2013-1-8 14:16