麻辣家族討論版版 - Powered by Discuz! Board

標題: 資料相同排在同一列的問題 [打印本頁]

作者: lionliu 時間: 2012-4-3 12:33 標題: 資料相同排在同一列的問題

各位大大想請教我有如附件的報表我要如何才能快速完成
[attach]10281[/attach]

作者: register313 時間: 2012-4-3 13:41

回復 1# lionliu

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

複製代碼

作者: GBKEE 時間: 2012-4-3 14:20

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

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

複製代碼

作者: hugh0620 時間: 2012-4-3 14:22

回復 1# lionliu

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

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

複製代碼

作者: register313 時間: 2012-4-3 14:43

回復 3# GBKEE

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

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

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

作者: GBKEE 時間: 2012-4-3 14:54

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

作者: lionliu 時間: 2012-4-3 17:38

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

作者: hugh0620 時間: 2012-4-3 19:19

回復 6# GBKEE

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

作者: GBKEE 時間: 2012-4-3 20:37

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

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

複製代碼

作者: Andy2483 時間: 2023-4-6 16:24

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

執行前:
[attach]36088[/attach]

執行結果:
[attach]36089[/attach]

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

作者: Andy2483 時間: 2023-4-7 09:52

謝謝論壇,謝謝各位前輩
後學今天練習陣列與字典,將陣列一次寫入儲存格,練習方案如下,請各位前輩指教

Option Explicit
Sub TEST_1()
Dim Brr, Crr, V, Y, R&, C%, i&, T$, xR As Range, Ma%
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, "A").End(3)): Brr = xR
ReDim Crr(1 To UBound(Brr), 1 To Columns.Count - 14)
For i = 1 To UBound(Brr)
T = Brr(i, 2)
If Y(T & "/R") = "" Then
   R = R + 1: Y(T & "/C") = 1
   Y(T & "/R") = R: Crr(R, 1) = Brr(i, 2)
   Else
      Y(T & "/C") = Y(T & "/C") + 1
      Crr(Y(T & "/R"), Y(T & "/C")) = Brr(i, 1)
End If
If Y(T & "/C") > Ma Then Ma = Y(T & "/C")
Next
[N1].Resize(, Ma).EntireColumn.Clear
[N7].Resize(R, Ma) = Crr: [N6] = [B1]
[N7].CurrentRegion.Borders.LineStyle = 1
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)