Validation Sum (Macro)

[James bolton]

Hi,

I would like to create a macro that performs a simple validation.

The minimum SUM of column B, should be the COUNT of column A / 2% (0.02)

So say for example their are 3000 cells in column A, the minimum sum of column B should be 60, & if it is less than 60, then I would like to create a pop up that says something like "Warning - Sum of Column B is too low"

----

I would also like to write a separate macro that validates column A & B for blank cells, there should be no blanks between the first and last row - so if there are any blanks - a pop up should come up to say "Warning ! Blank cells present"

Any help would be greatly appreciated

 

[Luke M]

Here you go.

Sub ValidateValue()
Dim aCount As Long
Dim bSum As Double

'Get our values
aCount = WorksheetFunction.CountA(Range("A:A"))
bSum = WorksheetFunction.Sum(Range("B:B"))

'Do a comparison
If aCount * 0.02 > bSum Then
    MsgBox "Warning - Sum of Column B is too low."
Else
    MsgBox "All good"
End If

End Sub

Sub CheckBlanks()
Dim lastRowA As Long
Dim lastRowB As Long
Dim rngBlanksA As Range
Dim rngBlanksB As Range

'Find last rows
lastRowA = Cells(Rows.Count, "A").End(xlUp).Row
lastRowB = Cells(Rows.Count, "B").End(xlUp).Row

'Look for blanks
On Error Resume Next
Set rngBlanksA = Range("A1:A" & lastRowA).SpecialCells(xlCellTypeBlanks)
Set rngBlanksB = Range("B1:B" & lastRowB).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0

'Give output
If rngBlanksA Is Nothing And rngBlanksB Is Nothing Then
    MsgBox "All good"
Else
    MsgBox "Warning! Blank cells present"
End If
End Sub

 

[James bolton]

Thankyou so much for this - works perfectly,

Just wondering if it is possible to one up this - where there are blanks on column B - is it possible to add an input box that asks if you want to put a default figure in - & then autopopulates that onto all the blank cells in column B ?

 

[Luke M]

How's this?

Sub CheckBlanks()
Dim lastRowA As Long
Dim lastRowB As Long
Dim rngBlanksA As Range
Dim rngBlanksB As Range

'Find last rows
lastRowA = Cells(Rows.Count, "A").End(xlUp).Row
lastRowB = Cells(Rows.Count, "B").End(xlUp).Row

'Uncomment this section if you want to have both columns be same length
'If lastRowA > lastRowB Then
'    lastRowB = lastRowA
'Else
'    lastRowA = lastRowB
'End If

'Look for blanks
On Error Resume Next
Set rngBlanksA = Range("A1:A" & lastRowA).SpecialCells(xlCellTypeBlanks)
Set rngBlanksB = Range("B1:B" & lastRowB).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0

'Give output
If Not rngBlanksB Is Nothing Then
    'Ask user if they want to fill in blanks
    If MsgBox("Populate with a value?", vbYesNo, "Blanks found in col B") = vbYes Then
        rngBlanksB = InputBox("What value should go in col B blanks?", "Fill value")
    End If
End If
If rngBlanksA Is Nothing Then
    MsgBox "Col A is ok"
Else
    MsgBox "Warning! Blank cells present in col A"
End If
End Sub

One quick add-on, I wasn't originally sure if we should check each column independently for "last row", or if they should each have their own. Would be easy to change, just uncomment the section noted in code.

 

[James bolton]

oh merci ... merci tres tres beacoup

and the extra touch there with the length validation (Y) wish I could like this twice !