エクセルVBAで月別最大値を取得したい

質問

いつもお世話になっております。
要件がエクセルVBAで・・という事で困っています。エクセルの2010を使用しています。
今、添付画像のように、A列に日付、B列に金額が入っており、D列に月表示、E列に各月の金額MAXを入れたいのですが、どのように記述したら良いかわかりません。
調べてみたところ、月の切り替わりに空白が挿入されていれば、下記ソースで月毎のMAXが
抜けることが分かりました（D、E列への転記はわかりませんでしたが・・）。

Sub test1()
Dim Rng As Range
Dim c As Range
Set Rng = Range(Range("B1"), Cells(Rows.Count, Range("B1").Column).End(xlUp))_
.SpecialCells(xlCellTypeConstants)
For Each c In Rng.Areas
c(c.Count).Offset(1).Value = WorksheetFunction.Max(c)
Next
End Sub

データを抜きたいファイルおよび、シートが大量にあり、とりあえずsheet(1)だけでも
何とかしたいのですが、方法がわかりません。Accessならば集計クエリでグループ化、
最大値を抽出してやればいいのですが。

ご教示いただけますでしょうか。
宜しくお願い致します。

回答No.7

bunjii

回答No.6で関数による処理を提示しましたがVBAのプログラムについても不得手ながらコードを書いてみました。
本来なら変数の定義をすべきところを省略していますので、ご容赦ください。
Sub test1()
n = Cells(1, 2).End(xlDown).Row
Max = 0
r = 2
Cells(r, 4) = WorksheetFunction.EoMonth(Cells(2, 1), 0)
Cells(r, 4).NumberFormatLocal = "yyyy/m"
For i = 2 To n
If Cells(i, 1) > Cells(r, 4) Then
Cells(r, 5) = Max
Cells(r, 5).NumberFormatLocal = "\#,###"
Max = Cells(i, 2)
r = r + 1
Cells(r, 4) = WorksheetFunction.EoMonth(Cells(i, 1), 0)
Cells(r, 4).NumberFormatLocal = "yyyy/m"
End If
Max = Application.WorksheetFunction.Max(Cells(i, 2), Max)
Next i
Cells(r, 5) = Max
Cells(r, 5).NumberFormatLocal = "\#,###"
End Sub

お礼

bunjiiさん
お礼が遅くなり、大変申し訳ございませんでした。
ご教示頂いた内容にて得たい結果が得られております。
ありがとうございました。

回答No.6

bunjii

>要件がエクセルVBAで・・という事で困っています。
VBAに拘りますか？
Excelの組み込み関数でも目的に合う処理が可能です。
D2セルへ次の数式を設定し、下へ必要数コピーします。
=IF(ISTEXT(D1),EOMONTH(A2,0),IF(MAX(A:A)>D1,EOMONTH(OFFSET($A$1,MATCH(D1,A:A),0),0),""))
続いてE2セルへ次の数式を設定して下へ必要数コピーします。
=IF(D2="","",MAX(INDEX((A$2:A$34>EOMONTH(D2,-1))*(A$2:A$34<=D2)*B$2:B$34,0)))
B列の最大行番号は実際のデータ数に合わせて修正してください。
尚、添付画像はExcel 2013で検証した結果ですがExcel 2010でも再現できるはずです。（11行目から24行目まで非表示にしています）

お礼

bunjiiさん
お礼が遅くなり、大変申し訳ございませんでした。
VBAへの拘りという部分では、本件の要件定義になり、いろいろな方法で目的の事が実現できる中で
何を選択するか？の話になりますので、今回はVBAの選択になっています。VBA以外を選択する理由も
なかったという状況です。
ありがとうございました。

回答No.5

tsubu-yuki

マクロにこだわる余程の理由があるのであれば話は変わりますが、
> Accessならば集計クエリでグループ化、最大値を抽出
をご存じなのであればなおのことピボットテーブルをオススメします。
あくまでも私個人のイメージですが、いわゆるクロス集計のもう少し簡単な奴・・
という感覚ですので、アクセスをお使いになるのであれば難しいことは無いはずです。

手順はimogasiさんが仰る通りで滞りなく作成可能です。
一つだけ、グループ化の際に「年」も選択した方が正確かと。
　　※年が違う○月（2017年1月と2018年1月など）が同一に扱われてしまいます。
グループ化のダイアログで、Ctrl+クリックで複数選択できますので、
「年」と「月」を選択してＯＫで「年」グループが出来ます。

そんなこんなで、一例として
Dim DRange As Range
　　Range("D:E").Delete
　　Set DRange = Range(Range("A1"), Cells(Rows.Count, 2).End(xlUp))
　　ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
　　　　　　　　　　SourceData:=DRange, _
　　　　　　　　　　Version:=xlPivotTableVersion15).CreatePivotTable _
　　　　　　　　　　　　　　TableDestination:=Range("D1"), _
　　　　　　　　　　　　　　TableName:="ピボットテーブル", _
　　　　　　　　　　　　　　DefaultVersion:=xlPivotTableVersion15
　　With ActiveSheet.PivotTables("ピボットテーブル")
　　　　With .PivotFields("日付")
　　　　　　.Orientation = xlRowField
　　　　　　.Position = 1
　　　　End With
　　　　.ColumnGrand = False
　　　　.CompactLayoutRowHeader = "月別ＭＡＸ"

　　　　.AddDataField .PivotFields("金額"), "合計 / 金額", xlMax
　　　　Range("D2").Group Start:=True, _
　　　　　　　　　　　　　End:=True, _
　　　　　　　　　　　　　Periods:=Array(False, _
　　　　　　　　　　　　　　　　　　　　False, _
　　　　　　　　　　　　　　　　　　　　False, _
　　　　　　　　　　　　　　　　　　　　False, _
　　　　　　　　　　　　　　　　　　　　True, _
　　　　　　　　　　　　　　　　　　　　False, _
　　　　　　　　　　　　　　　　　　　　True)
　　　　With .PivotFields("合計 / 金額")
　　　　　　.Function = xlMax
　　　　　　.Caption = "金額ＭＡＸ"
　　　　End With
　　End With
「マクロの記録」を使って記録し、ちょっと手を加えただけですが、
参考までにどうぞ。

お礼

tsubu-yukiさん
お礼が遅くなり、大変申し訳ございませんでした。
ピボットテーブルについては、私自身が、現状では何となく避けてしまっている部分でした。
ピボットテーブルを使って５分もかけずに処理完了している事を考えれば、時間の無駄が
発生しているとのご指摘も納得です。
これを機にどのような場合に有効に使えるのか掘り下げてみます。ありがとうございました。

回答No.4

imogasi

＞エクセルVBAで・・という事で困っています
先輩に言われて、ＶＢＡの勉強中か？
普通は関数でやろうという人が、多いと思うが。
多分他の回答者と違って、ピボットテーブルの操作をして、マクロの記録を取ることを勧める。
例データ　Ａ，Ｂ列
日付 値
2017/9/11 12
2017/9/18 8
2017/9/30 45
2017/10/11 8
2017/10/18 34
2017/10/30 25
2017/11/11 8
2017/11/18 7
2017/11/30 28
ーー
操作
範囲指定（見出し＋データ行）
挿入
ピボットテーブル
ＯＫ
日付を「行」にＤ＆Ｄ
値を「Σ値」へＤ＆Ｄ
ーー
（ピボットテーブルで出たシートで）
Ａ列（日付）で右クリック
「グループ化」
月
ＯＫ
（ピボットテーブルで出たシートで）
B列で右クリック
値の集計方法
最大値
＝＝＝
マクロの記録では
Sub Macro2()
'
' Macro2 Macro
Range("A1:B10").Select
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R10C2", Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:="Sheet7!R3C1", TableName:="ピボットテーブル5", DefaultVersion _
:=xlPivotTableVersion15
Sheets("Sheet7").Select
Cells(3, 1).Select
Sheets("Sheet7").Select
With ActiveSheet.PivotTables("ピボットテーブル5").PivotFields("日付")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("ピボットテーブル5").AddDataField ActiveSheet.PivotTables( _
"ピボットテーブル5").PivotFields("価"), "合計 / 値", xlSum
Range("A8").Select
Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
False, True, False, False)
Range("B5").Select
ActiveSheet.PivotTables("ピボットテーブル5").PivotFields("合計 / 価").Function = xlMax
End Sub
となった。
ーー
ピボットテーブル5　　の５などは場合に応じて変わります。
データが変わった時（本番などで）は、セル番地などはどう対応して変化するか
追ってください。
ビジネスでは、本件など、私が先輩なら、「関数やＶＢＡでなくピボットを使え！関数やＶＢＡは時間のロスだ」といてやるがね。
ーー
その他のやり方案
１行ずつデータを読んで、年と月を出して両者を文字列結合して、何月かを判別し、その前の行までの月別の最大値（月数だけ複数設ける手もある）と比べて、今回の行が大なら、その月の最大値を置き換える、を最終行まで、繰り返す。
こういうのが普通に思いつくロジックかな。

お礼

imogasiさん
お礼が遅くなり、大変申し訳ございませんでした。
また、いつもありがとうございます。
VBAの得意な人に話を聞くと、今回のような事例の場合には、　＞その他のやり方案　でご提示頂いた
ロジックで処理させる・・という回答でした。
ピボットテーブルについては、私自身が、現状では何となく避けてしまっている部分ですので、
これを機にどのような場合に有効に使えるのか掘り下げてみます。
ありがとうございました。

回答No.3

watabe007

>月の切り替わりに空白が挿入されていれば
見落としていました。対策を
Sub Test2()
　　Dim myDic1 As Object, myDic2 As Object
　　Dim c As Range, ym As String
　　Set myDic1 = CreateObject("Scripting.Dictionary")
　　Set myDic2 = CreateObject("Scripting.Dictionary")
　　For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
　　　　If IsDate(c.Value) Then
　　　　　　ym = "'" & Format(c.Value, "yyyy/mm")
　　　　　　myDic1(ym) = c.Offset(, 1).Value
　　　　　　If myDic2(ym) < myDic1(ym) Then myDic2(ym) = myDic1(ym)
　　　　End If
　　Next
　　Range("D2").Resize(myDic2.Count).Value = Application.Transpose(myDic2.keys)
　　Range("E2").Resize(myDic2.Count).Value = Application.Transpose(myDic2.Items)
End Sub

お礼

watabe007さん
お礼が遅くなり、大変申し訳ございませんでした。
ご教示頂いた内容にて得たい結果が得られております。
調べてみましたら、連想配列を使っているとの事で、初めて知った内容でした。
とても面白く、今後につながりそうです。
ありがとうございました。

回答No.2

watabe007

参考に
Sub Test2()
　　Dim myDic As Object
　　Dim c As Range, ym As String
　　Set myDic1 = CreateObject("Scripting.Dictionary")
　　Set myDic2 = CreateObject("Scripting.Dictionary")
　　For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
　　　　ym = "'" & Format(c.Value, "yyyy/mm")
　　　　myDic1(ym) = c.Offset(, 1).Value
　　　　If myDic2(ym) < myDic1(ym) Then myDic2(ym) = myDic1(ym)
　　Next
　　Range("D2").Resize(myDic2.Count).Value = Application.Transpose(myDic2.keys)
　　Range("E2").Resize(myDic2.Count).Value = Application.Transpose(myDic2.Items)
End Sub

回答No.1

f272

日付はA2から下に並んでいる。
それに対応する金額はB列の同じ行にある。
日付は昇順に並んでいる。
日付には空白行はない。
書き出しはD列とE列におこなう。
という前提で...
Sub test()
Set oo = Range("a2")
n = oo.End(xlDown).Row
k = 0
a1 = oo.Resize(n - 1, 2)
y1 = Year(a1(1, 1))
m1 = Month(a1(1, 1))
m2 = a1(1, 2)
For i = 2 To n - 1
If Month(a1(i, 1)) = m1 Then
If m2 < a1(i, 2) Then m2 = a1(i, 2)
Else
oo.Offset(k, 3) = DateSerial(y1, m1, 1)
oo.Offset(k, 4) = m2
k = k + 1
y1 = Year(a1(i, 1))
m1 = Month(a1(i, 1))
m2 = a1(i, 2)
End If
Next i
oo.Offset(k, 3) = DateSerial(y1, m1, 1)
oo.Offset(k, 4) = m2
End Sub

お礼

f272さん
お礼が遅くなり、大変申し訳ございませんでした。
ご教示頂いた内容にて得たい結果が得られております。
ありがとうございました。