[VBA]統合セルに、隣にある数字の最大値を表示

質問

VBA初心者です。

現在業務にてエクセルを使用した計算表を作成しているのですが、
指定のテンプレートに沿って作成しなければならない為、
一部の作業が難航しております。

内容は、変則的に統合されたセルの横にある数字の最大値を、
統合セルに表示させるというものです。
※詳細は添付画像をご参照ください。

関数などを用いて計算させようとしたのですが、セルが統合されているため、
結局手動で入力するのと時間に大差ないことが分かりました。

また、行数にすると1000行以上ある表を編集しなくてはなりませんので、
VBAによる作業を検討しております。

つきましては、大変恐縮ではありますが、どちらかお分かりになる方がおりましたら、
ご助力いただけると助かります。

作業環境は
Windows7　Excel2010　です。

勉強不足で申し訳ありませんが、よろしくお願いいたしjます。

回答No.2

keithin · ベストアンサー

もうちょっと簡単になりそうですが、とりあえず。

sub macro1()
　range("B1").select
　do until activecell.offset(0, 1) = ""
　　selection.value = application.max(activecell.offset(0,1).resize(activecell.mergearea.rows.count, 1))
　　selection.offset(1).select
　loop
end sub

お礼

とても素晴らしいです!!

こんなシンプルな書式にもかかわらず、
ばっちり希望通りの動作を確認しました。

しかも、スピードも高速でしたので、
申し分ありません。

大変勉強させられました。

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

回答No.3

MarcoRossiItaly

No.2 さんのとだいたい一緒ですが、MAX 関数を結合されたセルに記入するコード書いてみました。C 列の最終行のところまで、B 列に記入します。B 列の途中に結合されていない箇所があっても大丈夫です。C 列の途中に空白セルがあっても大丈夫。E 列と F 列とかで同じことしたい場合は、「b1」って箇所を E 列の番地に書き換えてもらえば対応できます。

それにしても、こんなデザインのテンプレートで 1,000 行以上って、作業させられる側にしてみれば、ちょっとモチベーション下がっちゃいますよね…。どうしてこうなっちゃうのでしょう。

Option Explicit

Sub set_fmax()

Dim c As Range
Dim n As Long

'↓「b1」など、セルを結合している列の中で最上端の位置にあるセルの番地を記述

Set c = Range("b1")

Do While c.Row <= Cells(Rows.Count, c.Column + 1).End(xlUp).Row
　　n = c.MergeArea.Count
　　c.Formula = "=max(" & c.Offset(0, 1).Resize(n).Address(0, 0) & ")"
　　Set c = c.Offset(1)
Loop

MsgBox c.Row - 1 & " 行目までを参照して数式を記入しました。"

End Sub

お礼

早々のお返事ありがとうございました。
MAX関数は手動で使用したことはあったのですが、
VBAで自動入力できることに、大変驚きを感じております。

説明も分かりやすく、感謝しております。

動作確認しましたが、希望通りの処理を行うことができました。

引き続き業務を頑張ります。

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

回答No.1

tom04

こんばんは！
一例です。

シートモジュールです。

Sub Sample1()
Dim i As Long, cnt As Long
Application.ScreenUpdating = False
Range("B:B").Insert
For i = 1 To Cells(Rows.Count, 4).End(xlUp).Row
With Cells(i, 3)
.Formula = "=row()"
.Value = .Value
End With
Cells(i, 2) = Cells(i, 3)
Next i
For i = 1 To Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 2) = "" Then
Cells(i, 2) = Cells(i - 1, 2)
End If
Next i
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
cnt = i
Do While Cells(cnt + 1, 2) = Cells(cnt, 2)
cnt = cnt + 1
Loop
Cells(i, 3) = WorksheetFunction.Max(Range(Cells(i, 4), Cells(cnt, 4)))
i = cnt
Next i
Range("B:B").Delete
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　三重にループしていますので、若干時間がかかるかもしれません。m(_ _)m

お礼

時間がかかるどころか、今までの手作業に比べ
比較にならないくらいのスピードに感動をおぼえております。

素晴らしい方法を教えていただきありがとうございます。

早速業務に取り入れていきたいと思います。

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