マクロをご教示ください。

質問

(1)　Ｃ列に顧客番号を表示しその時の販売金額をＨ列に表示しております。
　　　　顧客番号はＣ６からＣ１０００に発生順に表示しているため顧客番号は順不同です。
　　　　販売金額はＨ６からＨ１０００に発生順に表示していますす。
　　　　　　　　列番号　Ｃ　　　　列番号　Ｈ
行番号　　　　顧客番号　　　　　　金額
　　6　　　　　　　　100　　　　　　　　2000
　　7　　　　　　　　　30　　　　　　　　3000
　～　　　　　　　　　500　　　　　　　　　10
　100　　　　　　　　30　　　　　　　　20000
　～　　　　　　　　　100　　　　　　　25000
　700　　　　　　　　３０　　　　　　　　5000
　～　　　　　　　　　200　　　　　　　　500
1000　　　　　　　　100　　　　　　　10000

(2) 上記(1)の表を顧客別・金額順に並べ替えた表を作成したい。
顧客番号はＰ６からＰ１０００に昇順に表示したい。
販売金額はＱ６からＺ６に高額順に表示したい。
　　　　　　列番号Ｐ　　　列番号Ｑ　　　列番号Ｒ　　　列番号Ｓ　　　～　列番号Ｚ
行番号　　顧客番号　　 金額１　　 金額２　　 金額３　 　金額10
　　6　　　　　　30　 　20000 5000 3000
7 100 25000 10000 2000
8 200 500
9 500 10
～1000

● ご教示のほど宜しくお願い致します。

回答No.2

keithin · ベストアンサー

一個一個マクロでデータを拾っていっても構いませんが，まぁ折角ですからエクセルにやらせてみましょう。

Sub macro1()
　Dim r As Long, h As Long, p As Long
’準備
　Range("P6:Z65536").ClearContents
　Range("C:C").Copy
　Range("P:P").Insert shift:=xlShiftToRight
　Range("H:H").Copy
　Range("Q:Q").Insert shift:=xlShiftToRight

’並べ替え
　Range("P6:Q" & Range("Q65536").End(xlUp).Row).Sort _
　　key1:=Range("P6"), order1:=xlAscending, _
　　key2:=Range("Q6"), order2:=xlDescending, _
　　header:=xlNo

’転記
　r = 6
　p = 6
　Do Until Cells(r, "P") = ""
　　h = Application.CountIf(Range("P:P"), Cells(r, "P"))
　　Cells(p, "R") = Cells(r, "P")
　　Cells(p, "S").Resize(1, h).Value = Application.Transpose(Cells(r, "Q").Resize(h, 1).Value)
　　r = r + h
　　p = p + 1
　Loop

’片付け
　Range("P:Q").Delete shift:=xlShiftToLeft
　Cells.EntireColumn.AutoFit
End Sub

お礼

keithin様

ご教示ありがとうございました。

ご教示により思い通りの処理が出来ました。

御礼が遅れました事お詫びいたします。

今後とも宜しくお願い致します。

oguno

回答No.1

tom04

こんばんは！
一例です。

必ず1000行目までデータがあるとしてのコードです。
画面左下にある操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面が出ますので
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i, j As Long
Cells(5, 16) = "顧客番号"
Application.ScreenUpdating = False
For i = 6 To 1000
If WorksheetFunction.CountIf(Columns(16), Cells(i, 3)) = 0 Then
Cells(Rows.Count, 16).End(xlUp).Offset(1) = Cells(i, 3)
End If
Next i
j = Cells(Rows.Count, 16).End(xlUp).Row
Range(Cells(6, 16), Cells(j, 16)).Sort key1:=Cells(5, 16), order1:=xlAscending
For j = 6 To Cells(Rows.Count, 16).End(xlUp).Row
For i = 6 To 1000
If Cells(i, 3) = Cells(j, 16) Then
Cells(j, Columns.Count).End(xlToLeft).Offset(, 1) = Cells(i, 8)
End If
Next i
Next j
For j = 17 To ActiveSheet.UsedRange.Columns.Count
If WorksheetFunction.Count(Columns(j)) Then
Cells(5, Columns.Count).End(xlToLeft).Offset(, 1) = "金額" & j - 16
End If
Next j
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

tom04様

ご教示ありがとうございました。

今後とも宜しくお願い致します。