列、行範囲中の最大値、最小値探索

Visual Basic for Applications

Sub Macro()
  Dim Sheet As Integer
  Dim srrr As Integer
  Dim sccc As Integer
  Dim rrr As Integer
  Dim ccc As Integer
  Dim EndRow As Integer
  Dim EndCol As Integer
  Dim DataSetRow As Range
  Dim DataSetCol As Range
  Dim MaxRow As Single
  Dim MaxCol As Single
  Dim MinRow As Single
  Dim MinCol As Single
  Sheet = 1
  srrr = 1
  sccc = 1
  EndRow = Worksheets(Sheet).Cells(srrr, sccc).End(xlDown).Row
  EndCol = Worksheets(Sheet).Cells(srrr, sccc).End(xlToRight).Column
  Set DataSetRow = Range(Cells(srrr, sccc), Cells(EndRow, sccc))
  Set DataSetCol = Range(Cells(EndRow, sccc), Cells(EndRow, EndCol))
  MaxRow = Application.WorksheetFunction.Max(DataSetRow)
  MaxCol = Application.WorksheetFunction.Max(DataSetCol)
  MinRow = Application.WorksheetFunction.Min(DataSetRow)
  MinCol = Application.WorksheetFunction.Min(DataSetCol)
  For rrr = srrr To EndRow
    tmp = Worksheets(Sheet).Cells(rrr, sccc)
    If tmp = MaxRow Then
        Cells(rrr, sccc).Select
        Selection.Font.Bold = True
        Selection.Font.Italic = True
        Selection.Font.Underline = xlUnderlineStyleSingle
        With Selection.Font
            .Color = -16776961
            .TintAndShade = 0
        End With
    End If
    If tmp = MinRow Then
        Cells(rrr, sccc).Select
        Selection.Font.Bold = True
        Selection.Font.Italic = True
        Selection.Font.Underline = xlUnderlineStyleSingle
        With Selection.Font
            .Color = -4165632
            .TintAndShade = 0
        End With
    End If
  Next rrr
  For ccc = sccc To EndCol
    tmp = Worksheets(Sheet).Cells(EndRow, ccc)
    If tmp = MaxCol Then
        Cells(EndRow, ccc).Select
        Selection.Font.Bold = True
        Selection.Font.Italic = True
        Selection.Font.Underline = xlUnderlineStyleSingle
        With Selection.Font
            .Color = -16776961
            .TintAndShade = 0
        End With
    End If
    If tmp = MinCol Then
        Cells(EndRow, ccc).Select
        Selection.Font.Bold = True
        Selection.Font.Italic = True
        Selection.Font.Underline = xlUnderlineStyleSingle
        With Selection.Font
            .Color = -4165632
            .TintAndShade = 0
        End With
    End If
  Next ccc
End Sub