Counting Blank Cells

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.

Code:

---

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

Code:

---

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

---

THANK YOU!

This works perfectly!

:friends:

Code:

---

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

---

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
....

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.

Code:

---

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

---

Quote:

---

Originally Posted by 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
....

---

Code:

---

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

---