Max Value in a column exclude selection - Excel VBA

[magix]

Hi,

I used the below formula to find the max value in a column, and increment it
to the selection cell.

If Application.Count(Columns(1)) Then
MaxValue = Application.Max(Columns(1))
Else
MaxValue = 0
End If

If Application.CountA(Selection) = 0 Then
Selection.Value = MaxValue + 1
Else
If MsgBox("There are values in the selection. Are you sure you want to
replace?", vbQuestion + vbYesNo) = vbYes Then
' Check OK or Cancel, If OK, replace, if Not OK, abort
Selection.Value = MaxValue + 1
End If
End If


Example:
A1 has value 1
A2 has value 1
A3 has value 2

If I select A4, and click my macro button, it will put in value 3

My concern is like this:
If I select A3, it will prompt the mesg that if I want to replace it, then
if I click yes, it will put value 3
But I want it to put value 2, so that when find the max value, it actually
find all in the column , EXCLUDE those in the selection. How can I add those
checking in finding max value in a column excluding those in selection ?

I hope you got what I mean.

Thanks.

Regards.

 

[Dave Peterson]

I think...

Option Explicit
Sub testme01()
Dim myRng As Range
Dim CurSel As Range
Dim myCell As Range
Dim MaxValue As Double

Set CurSel = Selection
For Each myCell In Intersect(Columns(1), ActiveSheet.UsedRange).Cells
If Intersect(myCell, CurSel) Is Nothing Then
If myRng Is Nothing Then
Set myRng = myCell
Else
Set myRng = Union(myCell, myRng)
End If
End If
Next myCell

If myRng Is Nothing Then
'can't do max!
MaxValue = 0
MsgBox MaxValue & vbLf & "no cells looked at"
Else
MaxValue = Application.Max(myRng)
MsgBox MaxValue & vbLf & myRng.Address(0, 0)
End If

'rest of your code...
'remove the msgbox's when you're happy with your tests.
End Sub

 

[magix]

I think...

Option Explicit
Sub testme01()
Dim myRng As Range
Dim CurSel As Range
Dim myCell As Range
Dim MaxValue As Double

Set CurSel = Selection
For Each myCell In Intersect(Columns(1), ActiveSheet.UsedRange).Cells
If Intersect(myCell, CurSel) Is Nothing Then
If myRng Is Nothing Then
Set myRng = myCell
Else
Set myRng = Union(myCell, myRng)
End If
End If
Next myCell

If myRng Is Nothing Then
'can't do max!
MaxValue = 0
MsgBox MaxValue & vbLf & "no cells looked at"
Else
MaxValue = Application.Max(myRng)
MsgBox MaxValue & vbLf & myRng.Address(0, 0)
End If

'rest of your code...
'remove the msgbox's when you're happy with your tests.
End Sub

Hi Dave,

there is a bug in this statement.
"For Each myCell In Intersect(Columns(1), ActiveSheet.UsedRange).Cells"

If currently all the cells in Column A is empty (No value), it will return
error.

Regards,
Magix

 

[Dave Peterson]

You can check before you loop through those cells:

Option Explicit
Sub testme01()
Dim myRng As Range
Dim CurSel As Range
Dim myCell As Range
Dim MaxValue As Double
Dim RngToCheck As Range

Set RngToCheck = Nothing
On Error Resume Next
Set RngToCheck = Intersect(Columns(1), ActiveSheet.UsedRange).Cells
On Error GoTo 0

If RngToCheck Is Nothing Then
MsgBox "Column 1 is not in the used range"
Exit Sub
End If

Set CurSel = Selection
For Each myCell In RngToCheck.Cells
If Intersect(myCell, CurSel) Is Nothing Then
If myRng Is Nothing Then
Set myRng = myCell
Else
Set myRng = Union(myCell, myRng)
End If
End If
Next myCell

If myRng Is Nothing Then
'can't do max!
MaxValue = 0
MsgBox MaxValue & vbLf & "no cells looked at"
Else
MaxValue = Application.Max(myRng)
MsgBox MaxValue & vbLf & myRng.Address(0, 0)
End If

'rest of your code...
'remove the msgbox's when you're happy with your tests.
End Sub