Loop not quite working correctly
Hi Garry and Claus,
Here is the finished product, a before close alert for blank cells, and an alert box of those blank cells.
Thanks a ton for the excellent codes.
Howard
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim myCnt As Long, Diff As Long
Dim OneRng As Range, sBlanks$, vMsg
Set OneRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
myCnt = Application.CountA(OneRng)
Diff = Cells(Rows.Count, "A").End(xlUp).Row - myCnt
If Not Me.Saved Then
If Diff 0 Then
MsgBox "Cells A1 to A" & myCnt & " " & _
" must have values before " _
& vbCr & " the workbook is closed or saved!" _
& vbCr & vbCr & _
" " & Diff & _
" cells are empty!", vbExclamation, "Blank Cells Alert"
Cancel = True
End If
End If
If Application.CountBlank(OneRng) = 0 Then
'Exit Sub
vMsg = "No blanks found"
Else
sBlanks = OneRng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
sBlanks = Join(Split(sBlanks, ","), Chr(10))
vMsg = "Blanks cells a" & vbLf & vbLf & sBlanks
End If
MsgBox vMsg, vbInformation
End Sub
|