資料相同排在同一列的問題

lionliu

各位大大想請教我有如附件的報表我要如何才能快速完成
DATA.rar (7.65 KB)

下載次數: 19

2012-4-3 12:32

register313

回復 1# lionliu

1. Sub xx()
   
2. Columns("D:IV") = ""
   
3. [D6] = "BRAND"
   
4. For Each a In Range([B2], [B65536].End(xlUp))
   
5.   Set Rng = Columns("D").Find(a, , , xlWhole)
   
6.   If Rng Is Nothing Then [D65536].End(xlUp).Offset(1, 0) = a
   
7.   Set Rng = Columns("D").Find(a, , , xlWhole).Offset(0, 252)
   
8.   Rng.End(xlToLeft).Offset(0, 1) = a.Offset(0, -1)
   
9. Next
   
10. End Sub

複製代碼

GBKEE

回復 2# register313
不用字典物件可少用一次迴圈, 這不錯 ,可再簡化一下

1. Sub Ex()
   
2.     Dim A As Range, xf As Integer
   
3.     Sheet1.Activate
   
4.     'Sheets("原始資料").Activate
   
5.     Columns("D:IV") = ""
   
6.     Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D6"), Unique:=True
   
7.     For Each A In Range([B2], [B65536].End(xlUp))
   
8.         xf = Application.Match(A, Columns("D"), 0)
   
9.         Cells(xf, "IV").End(xlToLeft).Offset(, 1) = A.Offset(, -1)
   
10.     Next
    
11. End Sub

複製代碼

hugh0620

回復 1# lionliu

笨方法~ 可以用~ 但還是要依你的要的結果再去調整~

1. Sub EX()
   
2. For Each A In Range("B2:B21")
   
3.     B = Application.Match(A, Sheet1.Range("D7:D20"), 0)
   
4.     Cells(6 + B, 255).End(xlToLeft).Offset(0, 1) = A.Offset(0, -1)
   
5.     '6+B的用法是表是從第6列以後，因match是相對位置
   
6.     '例如完成表A是相對位置的第1列，所以6+1=7
   
7.     '完成表B是相對位置的第2列，所以6+2=8
   
8. Next
   
9. End Sub

複製代碼

register313

回復 3# GBKEE

GBKEE版主的指導與幫忙,小弟永遠記得

真正進入論壇學習,大約是去年10月左右
那時VBA的部份,一直在Range,Cells,Select,For...Next等基本語法的使用
到目前,應該說VBA有一些基礎,不過總覺得一直在同樣的地方繞來繞去,無法突破
原因自己清楚
1.工作並無此需求
2.自己並非認真學習(這是主因)

上論壇的原因
1.學習
2.幫助別人,自己也會有成就感
3.減少幾位超版,版主的負擔(應該沒有資格說這樣的話)
   我的一些解答是基礎版本(不是好的答案,只希望沒有錯誤)

GBKEE

回復 5# register313
我的工作用不上PC的,是興趣驅使來學習.有時也是回覆的七零八落地.

lionliu

好棒啊感謝各位大大幫忙現在測試中

hugh0620

回復 6# GBKEE

  看到G大跟r大的寫法~ 雖有不同~
  但有一點是相通的大家都是從最右邊往最左邊填入資料
  range("IV"& n).end(xltoleft).offset(0,1)
  怎麼都沒有人寫其他方式呢??

GBKEE

回復 8# hugh0620
由左向右   由右向左  隨個人喜好都可以

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim A As Range, xf As Integer, xC As Integer
   
4.     Sheet1.Activate
   
5.     'Sheets("原始資料").Activate
   
6.     Columns("D:IV") = ""
   
7.     Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D6"), Unique:=True
   
8.     For Each A In Range([B2], [B65536].End(xlUp))
   
9.         xf = Application.Match(A, Columns("D"), 0)
   
10.         xC = Application.CountA(Range(Cells(xf, "D"), Cells(xf, "D").End(xlToRight)))
    
11.         Cells(xf, "D").Offset(, xC) = A.Offset(, -1)
    
12.     Next
    
13. End Sub

複製代碼

Andy2483

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

執行前:

下載 (133.04 KB)

2023-4-6 16:23

執行結果:

下載 (152.35 KB)

2023-4-6 16:23

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, R&, C%, i&, T$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, "A").End(3)): Brr = xR
For i = 1 To UBound(Brr)
   T = Brr(i, 2): Y(T) = Y(T) + 1: If Y(T) > C Then C = Y(T)
Next
ReDim Crr(1 To Y.Count, 1 To C): V = Y.keys: Y.RemoveAll
For i = 1 To UBound(Brr)
   T = Brr(i, 2): If Y(T & "/R") = "" Then R = R + 1: Y(T & "/R") = R
   Y(T & "/C") = Y(T & "/C") + 1: Crr(Y(T & "/R"), Y(T & "/C")) = Brr(i, 1)
Next
[N:IV].Clear
[N7].Resize(UBound(V) + 1, 1) = Application.Transpose(V)
[O7].Resize(UBound(Crr), UBound(Crr, 2)) = Crr: [N6] = [B1]
[N7].CurrentRegion.Borders.LineStyle = 1
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr, V
End Sub