Thread: min max macro

Hi there,
My last question was answered so well I thought I'd ask another.
I have a column of data that is seperated by spaces, like so:

4
6
2
3

5
8
2
1
3

4
6
7

Each of the spaces between the groups is made up of three empty cells. In each space I want a min and max for the group of data above ie:

4
6
4
5
min of above
max of above

4
3
6
min of above
max of above

The groups of data will be of varying length. Is there a way I can fill in the gaps with min and max for all gaps and perhaps have the min max results in red font? If its possible to do it with one column, can I do it with multiple columns? ie:

3 5 8
4 6 8
1 4 9
2 5 7
min min min
max max max

3 6 5
3 6 8
2 8 2
min min min
max max max

Try this:

Option Explicit

Sub AddMinMax()
Dim RNG As Range, a As Long

On Error Resume Next
Set RNG = Range("A:A").SpecialCells(xlConstants)
If RNG Is Nothing Then Exit Sub
Application.ScreenUpdating = False

    For a = 1 To RNG.Areas.Count
        With Range(RNG.Areas(a).Address)
            .Cells(1).Offset(.Rows.Count).Value = Application.WorksheetFunction.Min(Range(.Address))
            .Cells(1).Offset(.Rows.Count).Font.ColorIndex = 3
            .Cells(1).Offset(.Rows.Count + 1).Value = Application.WorksheetFunction.Max(Range(.Address))
            .Cells(1).Offset(.Rows.Count + 1).Font.ColorIndex = 3
        End With
    Next a

Application.ScreenUpdating = True
End Sub

I can think of several thing you can do to your data make a multi-column macro not work correctly. So, no empty columns in between, ok? Try this:

Option Explicit

Sub AddMinMax()
Dim RNG As Range, a As Long, Col As Long

Col = Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
On Error Resume Next
Application.ScreenUpdating = False

For Col = 1 To Col
    Set RNG = Columns(Col).SpecialCells(xlConstants)
    If Not RNG Is Nothing Then
        For a = 1 To RNG.Areas.Count
            With Range(RNG.Areas(a).Address)
                .Cells(1).Offset(.Rows.Count).Value = Application.WorksheetFunction.Min(Range(.Address))
                .Cells(1).Offset(.Rows.Count).Font.ColorIndex = 3
                .Cells(1).Offset(.Rows.Count + 1).Value = Application.WorksheetFunction.Max(Range(.Address))
                .Cells(1).Offset(.Rows.Count + 1).Font.ColorIndex = 3
            End With
        Next a
    End If
Next Col

Application.ScreenUpdating = True
End Sub