Consulting

Results 1 to 7 of 7

Thread: Counting Blank Cells

  1. #1
    VBAX Tutor Philcjr's Avatar
    Joined
    Jul 2005
    Location
    Bedminster, NJ
    Posts
    208
    Location

    Counting Blank Cells

    Need some help here...

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

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    VBAX Tutor Philcjr's Avatar
    Joined
    Jul 2005
    Location
    Bedminster, NJ
    Posts
    208
    Location
    THANK YOU!

    This works perfectly!


  4. #4
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  5. #5
    VBAX Tutor Philcjr's Avatar
    Joined
    Jul 2005
    Location
    Bedminster, NJ
    Posts
    208
    Location
    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
    ....

  6. #6
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    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
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  7. #7
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    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
    ....

    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
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •