【Excel VBA】指定した行の最大値を持つセル番地を取得したい

質問

指定した範囲内で最大値及び最小値のセル番地を取得するには、
どうコーディングしたらよろしいでしょうか？

対象範囲　A1：Z2000の各行（行番は変数で処理）
例えば、
----------------------------------------------------
For x = 1 To 2000
Range(A列のx行目:A列のx行目)の最大値　→　B列
　　　　　　　　　　　　　　　最小値　→　Y列
Next x
----------------------------------------------------
このように、2000行分同じことを繰り返し、それぞれの行内での
最大値及び最小値を含むセルの列名を取得し、
B列のx行目を赤（最大値）
Y列のx行目を青（最小値）
に着色したいのです。

よろしくお願いします。

回答No.4

ka_na_de · ベストアンサー

＃１です。

高速化してみました。
配列は使ってません。

Sub test2()
　　Dim x As Long, y As Long, ct As Long
　　Dim myLastRow As Long, myLastCol As Long
　　Dim myMatchMaxCol As Long, myMatchMinCol As Long
　　Dim myMax As Double, myMIn As Double
　　Dim myRng As Range

　　myLastRow = Cells(Rows.Count, 1).End(xlUp).Row
　　myLastCol = Cells(1, Columns.Count).End(xlToLeft).Column

　　Application.ScreenUpdating = False
　　Range("A1").CurrentRegion.Interior.ColorIndex = xlNone
　　For x = 1 To myLastRow
　　　　Set myRng = Range(Cells(x, 1), Cells(x, myLastCol))
　　　　myMax = Application.WorksheetFunction.Max(myRng)
　　　　myMIn = Application.WorksheetFunction.Min(myRng)
　　　　myMatchMaxCol = Application.Match(myMax, myRng, 0)
　　　　myMatchMinCol = Application.Match(myMIn, myRng, 0)
　　　　Cells(x, myMatchMaxCol).Interior.ColorIndex = 3
　　　　Cells(x, myMatchMinCol).Interior.ColorIndex = 5
　　Next x
　　Application.ScreenUpdating = True

　　Set myRng = Nothing
End Sub

お礼

すいません、何度もありがとうございました。

できました！しかも非常に高速で。

いろいろ他の帳票にも応用が利きそうです。

回答No.5

mitarashi

#3です。もはや完全な余談ですが、
もともとセルに対するアクセスは最小限にとどめているコードですが、
#1さんの真似をして、Application.ScreenUpdating = Falseを取り入れると、試験データ生成部を除いたコードで、2329msec→2078msecと、1割位速くなりました。（時間は精度アップ対策をしたtimeGetTime APIで測定しているつもり）ご参考まで。

お礼

何度もご回答いただき、ありがとうございました！

Application.ScreenUpdating = False
これを取り入れると劇的に高速化しますね。

誠に申し訳ないのですが、
ソースは読解できなかったので今回は使用できなかったのですが、
スキルアップした際にはこの質問・ご回答をもう一度見直し、
是非とも参考にさせていただきたく思います。

回答No.3

mitarashi

徒然なるままに、こしらえてみました。最近高速化に凝っていますので、配列に入れて、オーソドックスな方法でやっています。実行時間はテストデータ生成を含めて3秒位でした（5年位前のCeleron機）採用されるときは、sh.Cells.Clearと、試験用データ生成部を削除してください。（当方XL2000です）
Sub test()
Dim tempArray As Variant
Dim i As Long, j As Long
Dim maxValue As Double, minValue As Double
Dim maxColumn As Long, minColumn As Long
Dim sh As Worksheet

Debug.Print Now
Set sh = ThisWorkbook.Sheets("Sheet1")
sh.Cells.Clear
tempArray = sh.Range("A1:Z2000")
'試験用データの生成
Randomize Now
For i = 1 To UBound(tempArray, 1)
For j = 1 To UBound(tempArray, 2)
tempArray(i, j) = Rnd() * 1000
Next j
Next i
Sheets("Sheet1").Range("A1:Z2000").Value = tempArray
Debug.Print Now
'ここからが本題
For i = 1 To UBound(tempArray, 1)
minValue = tempArray(i, 1): minColumn = 1
maxValue = tempArray(i, 1): maxColumn = 1
For j = 2 To UBound(tempArray, 2)
If minValue > tempArray(i, j) Then
minValue = tempArray(i, j)
minColumn = j
End If
If maxValue < tempArray(i, j) Then
maxValue = tempArray(i, j)
maxColumn = j
End If
Next j
With sh
.Cells(i, maxColumn).Interior.ColorIndex = 3
.Cells(i, minColumn).Interior.ColorIndex = 5
End With
Next i
Debug.Print Now
End Sub

回答No.2

ka_na_de

＃１です。

VBAの一例です。

Sub test1()
　　Dim x As Long, y As Long
　　Dim myLastRow As Long
　　Dim myMax As Double, myMIn As Double

　　myLastRow = Cells(Rows.Count, "A").End(xlUp).Row

　　For x = 1 To myLastRow
　　　　myMax = Application.WorksheetFunction.Max(Range(Cells(x, "A"), Cells(x, "Z")))
　　　　myMIn = Application.WorksheetFunction.Min(Range(Cells(x, "A"), Cells(x, "Z")))
　　　　For y = 1 To Range("Z1").Column
　　　　　　If Cells(x, y).Value = myMax Then
　　　　　　　　Cells(x, y).Interior.ColorIndex = 3
　　　　　　ElseIf Cells(x, y).Value = myMIn Then
　　　　　　　　Cells(x, y).Interior.ColorIndex = 5
　　　　　　Else
　　　　　　　　Cells(x, y).Interior.ColorIndex = xlNone
　　　　　　End If
　　　　Next y
　　Next x
End Sub

回答No.1

ka_na_de

条件付書式で簡単にできますよ。

図のように、条件付書式で数式を
=A1=MAX($A1:$Z1)

=A1=MIN($A1:$Z1)

に設定し書式のフォントまたはパターンを
それぞれ赤、青に設定してください。

お礼

画像入りのご回答、ありがとうございます。

私も条件式書式は知っていて活用していますが、
明細（行数）が万単位になるので、今回の場合もまず条件付き書式を設定しましたがブックが非常に重くなりフリーズする等の弊害が出たため、VBAでコントロールすることにした次第です。