【至急】Excelマクロで最大売上げ日を抽出する方法

質問

A,B,Cという3つの商品の売上げ数が日付で整理されているデータがあります。
この3商品に対して各月毎の最大売上げ日を抽出したいと考えています。
ただし、データの数が膨大で並びもぐちゃぐちゃなため、
マクロなしでは整理しにくい状態となっています。
データ整理の詳細については添付ファイルをご参照ください。

■背景
「今日中にデータ（Excel）を整理してほしい」という上司からの無茶振りで初めてのマクロを作成しております。
上司は、軽いセクハラをして帰ってしまいましたが…
私は、終わらなければ帰ることができないようです。
もし、お時間のある方がいらっしゃいましたら、ご指導ください。

以上、よろしくお願いいたします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.3

yucco_chan

汚い且つ突っ込みどころ満載ですが。。
制限：元データは、Sheet1にあり、A2からデータがある。
バグ：最大値が複数の日にある場合でも、若い日付しか表示されない。

Sub Sample1()
Dim MaxRow As Integer
Dim 商品数 As String
Dim i As Integer
Dim j As Integer

Dim 商品名 As String
Dim 年(10) As String
Dim dat, nowrow As Long, buf As String
Dim tp(31) As Integer
Dim con As Integer
Dim dmax As Integer
Dim drow As Integer
Dim dcol As Integer
Dim aaa As Integer
Dim Dend As Integer
Dim bbb As Integer
Dim zz As Integer

MaxRow = Range("C1").End(xlDown).Row
商品数 = 3 '商品のA,B,Cの種類数

nowrow = 2 '商品名などのデータは、2行目から始まる
dcol = 3 '
aaa = dcol
con = nowrow
dmax = 0
drow = 3

j = 1
Set dat = CreateObject("Scripting.Dictionary")

Do
年(j) = Year(Cells(nowrow, 2))
Sheets.Add
ActiveSheet.Name = 年(j)
Columns("B:B").Select
Selection.NumberFormatLocal = "yyyy/m/d;@"
Range("A1").Select
Sheets("Sheet1").Select
Sheets(年(j)).Cells(1, 1) = Cells(1, 1)
Sheets(年(j)).Cells(1, 2) = Cells(1, 2)
Sheets(年(j)).Cells(1, 3) = Cells(1, 3)

Do While 年(j) = Year(Cells(nowrow, 2))
If Cells(nowrow, 1) <> "" Then
商品名 = Cells(nowrow, 1)
End If
Sheets(年(j)).Cells(nowrow, 1) = 商品名
Sheets(年(j)).Cells(nowrow, 2) = Cells(nowrow, 2)
Sheets(年(j)).Cells(nowrow, 3) = Cells(nowrow, 3)
Sheets(年(j)).Cells(nowrow, 4) = Month(Cells(nowrow, 2))

buf = Sheets(年(j)).Cells(nowrow, 1).Value
If Not dat.Exists(buf) Then
dat.Add buf, buf
If buf <> "" Then
Sheets("Sheet2").Cells(2, dat.Count + dcol - 1) = buf
Sheets("Sheet2").Cells(1, dat.Count + dcol - 1) = Cells(1, 1)
ActiveWorkbook.Names.Add Name:=buf, RefersToR1C1:= _
"='Sheet2'!R1C" & dat.Count + dcol - 1 & ":R2C" & dat.Count + dcol - 1

End If
End If

Sheets("Sheet2").Cells(drow, dcol - 2) = 年(j) & "/" & Month(Cells(nowrow, 2))
Sheets("Sheet2").Cells(drow, dcol - 1) = "で最大売上げ日"
If Month(Cells(nowrow + 1, 2)) > Month(Cells(nowrow, 2)) Or _
Year(Cells(nowrow + 1, 2)) > Year(Cells(nowrow, 2)) Then
drow = drow + 1
ActiveWorkbook.Names.Add Name:="月" & Year(Cells(nowrow, 2)) & Month(Cells(nowrow, 2)), RefersToR1C1:= _
"=" & Year(Cells(nowrow, 2)) & "!R" & con & "C1:R" & nowrow & "C3"
Dend = Sheets("Sheet2").Cells(drow - 2, Columns.Count).End(xlToLeft).Column
For aaa = dcol To Dend
Sheets("Sheet2").Cells(drow - 1, aaa + 1) = "=DMAX('" & 年(j) & "'!$A$1:$C$1:" & "月" & Year(Cells(nowrow, 2)) & Month(Cells(nowrow, 2)) _
& ",'" & 年(j) & "'!$C$1," & Sheets("Sheet2").Cells(2, aaa) & ")"
For bbb = con To nowrow
If Sheets(年(j)).Cells(bbb, 3) = Sheets("Sheet2").Cells(drow - 1, aaa + 1) And _
Sheets(年(j)).Cells(bbb, 1) = Sheets("Sheet2").Cells(2, aaa) Then

Sheets("Sheet2").Cells(drow - 1, aaa) = Sheets(年(j)).Cells(bbb, 2)
End If

Next bbb
Sheets("Sheet2").Cells(drow - 1, aaa + 1) = ""
Next aaa

con = nowrow + 1
End If
If nowrow >= MaxRow Then Exit Do
nowrow = nowrow + 1
Loop
If j > 1 Then
Sheets(年(j)).Select
Rows("2:" & Range("B2").End(xlDown).Row - 1).Delete Shift:=xlUp
Sheets("Sheet1").Select
End If
If nowrow >= MaxRow Then Exit Do

j = j + 1
Loop
Application.DisplayAlerts = False
For i = j To 1 Step -1
Sheets(年(i)).Select
ActiveWindow.SelectedSheets.Delete
Next i
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Sheet2").Select
Cells.Select
Selection.NumberFormatLocal = "yyyy/m/d"
Range("A1").Select

End Sub

お礼

ありがとうございます！
とても長いプログラムですね。全て理解するには結構時間がかかりそうです。
私の作ったものと比較すると処理速度が2倍程度速いため、その原因を探るところから勉強していこうと考えています。
別の回答をして頂いた方も”Scripting.Dictionary”というオブジェクトを使われているようですが、マニュアルを見ても何のことやら？？という思いです。自分にとってマクロはかなり難しいです・・
でも、マクロの便利さには感動しております。
今日は画像をペタペタ貼る作業で、サイズやトリミングなどをショートカットキー1つで揃えることができ、業務の効率化を図ることができました。

これから、少しずつでもマクロを勉強していこうと思いますので、
もし別の質問等をお見かけなった際には、またご指導ください。

以上、ありがとうございました。

回答No.2

n-jun

回答１のお礼に書かれている表をセルＦ２以下に
A　2005/09　2005/9/4
B　2005/09　2005/9/8
C　2005/09　2005/9/7
と書き出すのなら、

Sub　try()
　Dim　myDic　As　Object
　Dim　r　As　Range,　s_name　As　String
　Dim　c　As　String
　Dim　myKey

　Set　myDic　=　CreateObject("Scripting.Dictionary")

　For　Each　r　In　Range("B2",　Cells(Rows.Count,　2).End(xlUp))
　　　　　s_name　=　IIf(LenB(r.Offset(,　-1).Value)　<>　0,　r.Offset(,　-1).Value,　s_name)
　　　　　c　=　s_name　&　"_"　&　Format(r.Value,　"yyyy/mm")
　　　　　If　Not　myDic.Exists(c)　Then
　　　　　　　　myDic(c)　=　Array(r.Value,　r.Offset(,　1).Value)
　　　　　ElseIf　r.Offset(,　1).Value　>　Val(myDic(c)(1))　Then
　　　　　　　　myDic(c)　=　Array(r.Value,　r.Offset(,　1).Value)
　　　　　End　If
　Next
　Set　r　=　Range("F2")

　For　Each　myKey　In　myDic.keys
　　　　　r.Resize(,　2).Value　=　Split(myKey,　"_")
　　　　　r.Offset(,　2).Value　=　myDic(myKey)(0)
　　　　　Set　r　=　r.Offset(1)
　Next
　Set　myDic　=　Nothing
　Set　r　=　Nothing
End　Sub

でも出来ますが、５万行越えでどうなのかは自信ないです。

お礼

ありがとうございます！！
昨日は集中力を高めるために、深夜からファミレスでやっていたので、返信が遅れました。すみません。
結局、今日の朝までには間に合わず、同僚の協力の下、昼過ぎくらいに完成させることができました。
ただし、n-junさんの10倍以上の行数になってしまいました・・・
ネットで色々なサンプルプログラムを見て思ったのですが、
プログラムをスマートに書くためには、オブジェクトという概念を勉強する必要があるようですね。
n-junさんのプログラムを見て勉強したいと思います。

以上、ありがとうございました！

回答No.1

yucco_chan

添付データーが見えません。
何が、どうぐちゃぐちゃなのか分からないので、何のアドバイスも出来ません

お礼

すみません。添付データを付けていたのですが、解像度が低く見れるものではなかったので消してしまいました。
データを下記に示します。
※実際のデータは、過去20年間分×仕向けでデータは50,000行を超えています・・・
※各月における日付の個数はバラバラです・・・
--------------------------
商品名　　日付　　売上げ数
A　　　　2005/9/1 10
　　　　 2005/9/2　11
　　　　 2005/9/3　20
　　　　 2005/9/4　41
　　　　 2005/9/5　10
　　　　 2005/9/6　5
　　　　 2005/9/7　10
B　　　　2005/9/1　10
　　　　 2005/9/2　11
　　　　 2005/9/3　20
　　　　 2005/9/4　41
　　　　 2005/9/5　10
　　　　 2005/9/6　5
　　　　 2005/9/7　10
　　　　 2005/9/8　58
　　　　 2005/9/9　13
C　　　　2005/9/1　10
　　　　 2005/9/2　11
　　　　 2005/9/3　20
　　　　 2005/9/4　20
　　　　 2005/9/5　10
　　　　 2005/9/6　5
　　　　 2005/9/7　52
　　　　 2005/9/8　20
--------------------------
上記データから、↓の形で最大売上げ日を抽出しようとしています。

　　　　　　　　　　　　　　　　　　A　　　　　　　　B　　　　　　　　C
2005/9で最大売上げ日　　2005/9/4　　　2005/9/8　　　2005/9/7
2005/10で最大売上げ日

補足

強制退社の時間になりましたので、自宅への持ち帰り仕事となりました。
徹夜になってでも完成させる所存ですので、よろしくお願いします。

現在、”do until～”と”For～”を使って処理しようと考えています。
1列目に対して”do until”で最大値を検索する行の範囲を求めて、
”For～”で上記範囲内の最大値を探すというやり方です。
ですが、どちらも先ほど理解したばかりですので、使い方がイマイチわかっていません。というより、マクロの記述に関する約束事を把握した程度ですので、先は長そうです…