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

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

Andy2483

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

執行前:

下載 (176.89 KB)

2023-4-13 16:13

輸入窗輸入"A":

下載 (140.75 KB)

2023-4-13 16:13

輸入窗輸入"B":

下載 (142.13 KB)

2023-4-13 16:14

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

c_c_lai

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

複製代碼

過程如附圖：

下載 (103.32 KB)

2013-1-8 17:56

Genie

回復 12# softsadwind


一開始 Hsieh 超級版主提供的程式執行起來會有一點問題
執行出來的結果可以去比對原始資料　會發現有幾個數值是沒有轉置成功的！

Genie

回復 11# Hsieh


沒錯！　資料量每欄都不同
不過這個程式解決了這個問題
非常謝謝～

softsadwind

回復 10# Genie


    我測試起來的結果是ok的說....
   

下載 (76.23 KB)

2013-1-8 16:08

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

下載 (4.33 KB)

2013-1-8 16:10

嘗試把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

不知道有人可以指點更方便的方式嗎？

Hsieh

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

1. Sub ex()
   
2. 
   
3. Dim A As Range, d As Object, j&, i%, s%, C$, Ky
   
4. 
   
5. C = InputBox("輸入欄位A或B", , "A")
   
6. 
   
7. Set d = CreateObject("Scripting.Dictionary")
   
8. 
   
9. With Sheet1
   
10. 
    
11. j = 2
    
12. 
    
13. Do Until .Cells(j, 1) = ""
    
14. 
    
15.   Set A = .Cells(j, C)
    
16. 
    
17.   s = Application.CountIf(.Range(A, A.End(xlDown)), A)
    
18. 
    
19.   i = Application.CountIf(A.Resize(s, 1), .Cells(j, C)) '計算單筆資料量
    
20. 
    
21.   If C = "A" Then
    
22. 
    
23.      d(A.Value) = A.Offset(, 2).Resize(i, 1).Value
    
24. 
    
25.      Else
    
26. 
    
27.      d(A.Offset(, -1) & "_" & A) = A.Offset(, 1).Resize(i, 1).Value
    
28. 
    
29.   End If
    
30. 
    
31. j = j + i
    
32. 
    
33. Loop
    
34. 
    
35. End With
    
36. 
    
37. With Sheet2
    
38. 
    
39. .UsedRange.Clear
    
40. 
    
41. k = 1
    
42. 
    
43. For Each Ky In d.keys
    
44. 
    
45.    .Cells(1, k) = Ky
    
46. 
    
47.    .Cells(2, k).Resize(UBound(d(Ky)), 1) = d(Ky)
    
48. 
    
49.    k = k + 1
    
50. 
    
51. Next
    
52. 
    
53. End With
    
54. 
    
55. End Sub

複製代碼

Genie

回復 8# Hsieh


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

下載 (37.81 KB)

2013-1-8 14:16

Genie

回復 6# GBKEE
回復 7# c_c_lai


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

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

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

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

複製代碼