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

複製代碼

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

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

Genie

回復 11# Hsieh


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

Genie

回復 12# softsadwind


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

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

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