Counting Blank Cells

[Philcjr]

Need some help here... :banghead:

Goal: Would like to return the number of blank cells for each column (Col A through Col L). This would be based upon the lastrow that has an entry. Within this range (A-L) Column A will ALWAYS have a value.

I cant even get this to work... after searching the net, books, etc.

Please help :help, this is what I have thus far... not much but I hope this helps.



Option Explicit

Sub CountBlanks()
Dim Blank As Integer, Row As Integer, x As Integer
Blank = 0
Row = Range("A65536").End(xlUp).Row
For x = 1 To Row Step 1
If IsEmpty(Range("A" & Row)) Then Blank = Blank + 1
Next x
MsgBox "There are " & Row & " rows in Column A." & vbLf & vbLf _
& "There are " & Blank & " blank cells in Column A. "
End Sub



Thanks,
Phil

[Bob Phillips]

Sub CountBlanks()
Dim Blank As Long, rng As Range
Dim col As Long, crows As Long
For col = 1 To 12
Set rng = Cells(1, col).Resize(Cells(Rows.Count, col).End(xlUp).Row)
Blank = Application.CountBlank(rng)
If Blank = 1 And Cells(1, col) = "" Then
Blank = 0
crows = 0
Else
crows = rng.Rows.Count
End If
MsgBox "There are " & crows & " rows in Column " & Chr(64 + col) & _
vbNewLine & vbNewLine _
& "There are " & Blank & " blank cells in Column " & Chr(64 + col)
Next col
End Sub

[Philcjr]

THANK YOU!

This works perfectly!

:friends:

[Bob Phillips]

Sub CountBlanks()
Dim Blank As Long, rng As Range
Dim col As Long, cRows As Long
Dim sMess As String
sMess = "Results:" & vbNewLine & vbNewLine
For col = 1 To 12
Set rng = Cells(1, col).Resize(Cells(Rows.Count, col).End(xlUp).Row)
Blank = Application.CountBlank(rng)
If Blank = 1 And Cells(1, col).Value = "" Then
Blank = 0
cRows = 0
Else
cRows = rng.Rows.Count
End If
sMess = sMess & Chr(col + 64) & " - " & cRows & " rows, " & _
Blank & " blank cells" & vbNewLine
Next col
MsgBox sMess, vbInformation, "Blank Cell Counter"
End Sub

[Philcjr]

Thanks... One last tweak

Can the message box look like this?

There are x rows (This would be the total from column A) that you have entered and should be compled.

Column A has x blank cells... Please fill-in
Column B has x blank cells... Please fill-in
Column C has x blank cells... Please fill-in
Column D has x blank cells... Please fill-in
....

[lucas]

Couple of things that might help along the lines of this discussion:

Ken(kpuls) has a script in the kb that forces the user to fill in specific cells before you can change to the next sheet:

http://www.vbaexpress.com/kb/getarticle.php?kb_id=546

This script put in your "ThisWorkbook" module will force a user to fill in a configurable range on multple sheets before the workbook can be closed and will highlight the cells that need data. I think Jacob(DRJ) posted this some time ago but I could not find it in the kb.


Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim shtName As String, Start As Boolean
Dim Rng1 As Range, Rng3 As Range, Rng4 As Range
Dim Rng2 As Range
Dim Prompt As String, RngStr As String
Dim Cell As Range
Set Rng1 = Sheets("Group Profile").Range("B5:B14,F1,F5:F7,B20:B22,B26:B31,B38:B45,B49:B52")
Set Rng3 = Sheets("Eligibility Guidelines").Range("F1,E5,E6,E9,E10,B7:B17,B21:B36")
Set Rng4 = Sheets("COBRA").Range("J2,H4,H5,J15,B4,B5,B9,B10:B13,B17:B20,B25:B28,E17: E20")
Prompt = "Please check your data ensuring all required " & _
"cells are complete." & vbCrLf & "you will not be able " & _
"to close or save the workbook until the form has been filled " & _
"out completely. " & vbCrLf & vbCrLf & _
"The following cells are incomplete and have been highlighted yellow:" _
& vbCrLf & vbCrLf
Start = True
For Each Cell In Rng1
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng3
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left(RngStr, Len(RngStr) - 2)
Start = True
If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
For Each Cell In Rng4
If Cell.Value = vbNullString Then
Cell.Interior.ColorIndex = 6 '** color yellow
If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
Start = False
RngStr = RngStr & Cell.Address(False, False) & ", "
Else
Cell.Interior.ColorIndex = 0 '** no color
End If
Next
If RngStr <> "" Then RngStr = Left(RngStr, Len(RngStr) - 2)
If RngStr <> "" Then
MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
Cancel = True
Else
ThisWorkbook.Save
Cancel = False
End If
End Sub

[Bob Phillips]

Thanks... One last tweak

Can the message box look like this?

There are x rows (This would be the total from column A) that you have entered and should be compled.

Column A has x blank cells... Please fill-in
Column B has x blank cells... Please fill-in
Column C has x blank cells... Please fill-in
Column D has x blank cells... Please fill-in
....



Sub CountBlanks()
Dim Blank As Long, rng As Range
Dim col As Long, cRows As Long
Dim sMess As String
cRows = Range("A1").Resize(Cells(Rows.Count, "A").End(xlUp).Row).Count
sMess = "There are " & cRows & " rows" & vbNewLine & vbNewLine
For col = 1 To 12
Set rng = Cells(1, col).Resize(Cells(Rows.Count, col).End(xlUp).Row)
Blank = Application.CountBlank(rng)
If Blank = 1 And Cells(1, col).Value = "" Then
Blank = cRows
End If
If Blank > 0 Then
sMess = sMess & "Coilumn " & Chr(col + 64) & " has " & _
Blank & " blank cells... Pleas fill-in" & vbNewLine
End If
Next col
MsgBox sMess, vbInformation, "Blank Cell Counter"
End Sub