asked on

Find column with max value

Hello Experts,

I need to start to my code from the Sheet.activate. I need to do this in vb since I have other code to add later, I want to avoid setting this up in the Excel sheet.

I need to find the column with the highest max value from range ("AG4:AK4") and then have have column +1.value to equal 50.

If you could guide me along with the next step too - it would be very helpful. The next step would be if AG5 = 50 then 'do this, if AH5 = 50 then 'do this etc etc.

I have tried numerous things but keep getting errors from object not set to other issues. I have given up and have turned to you guys.

thanks

mike637

ASKER

Experts,

I need to clarify a step - I need to reference back to the cell in the range that has the highest max value.

I stated earlier that I need to reference to the cell in row 5 that now equals 50 - that is incorrect, I need to add additional code from the cell that is identified from the range("AG4:AK4") .

This is where I need help with the 2nd step is how to reference that cell that has the max value and then do my additonal coding.

Step 1- is to have the max range cell add 50 to the next cell down.
Step 2 - write additional steps of code based off the position of the max range cell.

Thanks Experts.

dlmille

Here's one way, if you have one to many rows to examine:

Private Sub Worksheet_Activate()
Dim r As Range
Dim rng As Range
Dim rMaxRange As Range
Dim maxVal As Double 'assuming numeric values
Dim rNextCellDown As Range

    Set rng = Range("AG4:AK4")
    
    For Each r In rng
        If r.Value > maxVal Then
            maxVal = r.Value
            Set rMaxRange = r
        End If
    Next r
    
    If maxVal > 0 Then
        'add 50 to the next cell down
        Set rNextCellDown = rMaxRange.Offset(1, 0)
        rNextCellDown.Value = rNextCellDown.Value + 50
    End If
    
End Sub

Open in new window

And, if you're just working one row, the Evaluate of the MATCH(MAX function should work and be pretty efficient at it:

Private Sub Worksheet_Activate()
Dim r As Range
Dim rng As Range
Dim colMax As Variant
Dim rNextCellDown As Range

    Set rng = Range("AG4:AK4")
    
    'find first max value column in range - this only works if the range is on one row
    colMax = Evaluate("=MATCH(MAX(" & rng.Address & ")," & rng.Address & ",0)")
    
    If Not IsError(colMax) Then
        'add 50 to the next cell down
        Set rNextCellDown = rng.Cells(2, colMax)
        rNextCellDown.Value = rNextCellDown.Value + 50
    End If
    
End Sub

Open in new window

See attached example.

Dave
doWork-r1.xls

mike637

ASKER

Hi Dave,

Here is my final code. It does what I need it to do - however I have duplicated steps depending of the the r1.range value. I wanted to create a seperate sub-routine to call that would complete the duplicated steps - but I could not get it to do that. If you can take this exisiting code and slim it down, then that will help me greatly. That is if you have the time.

Thanks,
Michael

Private Sub Worksheet_Activate()

ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Me.Application.ActiveWindow.Zoom = 85

range("AG9,AI9,AK9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])" 'Reset WS with no formats
range("AG9:AK9").Font.Bold = False
range("AG38:AK38").Select
With Selection
.Font.Bold = False
.Font.ColorIndex = 1
.Interior.ColorIndex = xlNone
End With

Dim r As range, res As Variant
Dim r1 As range, lmax As Double
Set r = range("AG4:AK4")

lmax = Application.Max(r)
res = Application.Match(lmax, r, 0)

If Not IsError(res) Then
Set r1 = r(res)
r1.Select

If r1 = range("AG4") Then

range("AG9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])+1"

r1.Offset(5).Select
With Selection
.Font.Bold = True
End With

r1.Offset(34).Select
With Selection
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 14
End With

ActiveSheet.Shapes("DINNER1").Left = range("AG8").Left
ActiveSheet.Shapes("DINNER1").IncrementLeft -5.25

ElseIf r1 = range("AI4") Then

range("AI9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])+1"

r1.Offset(5).Select
With Selection
.Font.Bold = True
End With

r1.Offset(34).Select
With Selection
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 14
End With

ActiveSheet.Shapes("DINNER1").Left = range("AI8").Left
ActiveSheet.Shapes("DINNER1").IncrementLeft -5.25

ElseIf r1 = range("AK4") Then

range("AK9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])+1"

r1.Offset(5).Select
With Selection
.Font.Bold = True
End With

r1.Offset(34).Select
With Selection
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 14
End With

ActiveSheet.Shapes("DINNER1").Left = range("AK8").Left
ActiveSheet.Shapes("DINNER1").IncrementLeft -5.25
End If

Else
End If

range("G12").Select

End Sub

dlmille

Here's a first pass rewrite:

Private Sub Worksheet_Activate()
Dim r As Range, res As Variant
Dim r1 As Range, lmax As Double

    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Me.Application.ActiveWindow.Zoom = 85

    Range("AG9,AI9,AK9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])"    'Reset WS with no formats
    Range("AG9:AK9").Font.Bold = False
    
    With Range("AG38:AK38")
        .Font.Bold = False
        .Font.ColorIndex = 1
        .Interior.ColorIndex = xlNone
    End With

    Set r = Range("AG4:AK4")

    lmax = Application.Max(r)
    res = Application.Match(lmax, r, 0)

    If Not IsError(res) Then
    
        Set r1 = r(res)
        
        If Not Intersect(r1, Range("AG4")) Is Nothing Then

            Range("AG9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])+1"

            r1.Offset(5).Font.Bold = True
            With r1.Offset(34)
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 14
            End With

            ActiveSheet.Shapes("DINNER1").Left = Range("AG8").Left
            ActiveSheet.Shapes("DINNER1").IncrementLeft -5.25

        ElseIf Not Intersect(r1, Range("AI4")) Is Nothing Then

            Range("AI9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])+1"

            r1.Offset(5).Font.Bold = True

            With r1.Offset(34)
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 14
            End With

            ActiveSheet.Shapes("DINNER1").Left = Range("AI8").Left
            ActiveSheet.Shapes("DINNER1").IncrementLeft -5.25

        ElseIf Not Intersect(r1, Range("AK4")) Is Nothing Then

            Range("AK9").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C[1])+1"

            r1.Offset(5).Font.Bold = True

            With r1.Offset(34)
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 14
            End With

            ActiveSheet.Shapes("DINNER1").Left = Range("AK8").Left
            ActiveSheet.Shapes("DINNER1").IncrementLeft -5.25
        End If

    Else
        'do nothing
    End If

    Range("G12").Select

End Sub

Open in new window

ASKER CERTIFIED SOLUTION

dlmille

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

mike637

ASKER

Thanks for doing this - I learn something everytime form you guys.

Thanks again,
Michael