How to evaluate a range of cells in VB? Closed

Question

Hello, 

I am creating a monitoring form. I want it to evaluate the answers for each question. If the Auditor does not select one of the three answers, I want the auditor to get an error message informing them that a question has not been answered and the question to highlight yellow indicating which question was not answered.

This is what I have thus far:

Sub Submit()
       Dim Start As String
    Dim Rng1 As Range
    Dim Prompt As String, RngStr As String
    Dim Cell As Range
        Set Rng1 = Range("I11:K11")
        Start = True
     For Each Cell In Rng1
        If Cell.Value = "" Then
         MsgBox "Audit Form Incompete. Please review highlighted question(s)."
         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 = X '** no color
        End If


Currently, it gives an error message for each individual blank. I want it to evaluate the range as one and only give an error message and turn yellow if all options are blank.

Thanks in advance!!!

Configuration: Windows 7 / Firefox 3.6.3

RayH · Answer

Define a variable:
DIM errflag as integer

Then in place of the MsgBox statement put:
 let errflag=1

Move the MsgBox to the end of the section and change it to be:
If errflag Then MsgBox "Audit Form Incompete. Please review highlighted question(s)."

Stacey · Answer

I appreciate the help but I have add the info you have supplied and it doesn't work for me. I really believe I am doing something wrong. Could you please use the following code and highlight or make a note of exactly what I need to change?
Sub Submit()
       Dim Start As String
    Dim Rng1 As Range
    Dim Prompt As String, RngStr As String
    Dim Cell As Range
        Set Rng1 = Sheets("Auditing_Form").Range("I11:K11")
           Start = True
     For Each Cell In Rng1
        If Cell.Value <> "X" Then
         MsgBox "Audit Form Incompete. Please review highlighted question(s)."
         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 = X '** no color
        End If


I really appreciate your help!!!

RayH · Answer

Sub Submit() 
Dim Start As String 
Dim Rng1 As Range 
Dim Prompt As String, RngStr As String 
Dim Cell As Range 

' This is Change #1
DIM ErrFlag as Integer
Let ErrFlag=0 ' Reset the variable just to be sure

Set Rng1 = Sheets("Auditing_Form").Range("I11:K11") 
Start = True 
For Each Cell In Rng1 
If Cell.Value <> "X" Then 

' This is change #2
let ErrFlag=1

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 = X '** no color 
End If 

' This is Change #3
if ErrFlag then MsgBox "Audit Form Incompete. Please review highlighted question(s)."

RayH · Answer

Dont forget to include "Next Cell" afer the the last End If and before the MsgBox

Stacey · Answer

That works perfectly, only one problem now. The the blank cells are still turning yellow and the Error Message is still popping up for each cell in the Range I11:K11, except for the one I have marked. Is there any way to only turn the blank cells yellow and only show the error message if all three cells are left blank?

Thanks for your help!!!

RayH · Answer

This should satisfy section1.
Section 2 is almost the same except with a different range.


Dim Rng1 As Range
Dim Cell As Range
Dim errflag As Integer

Set Rng1 = Range("I8:K8")
Let errflag = 0

' For each cell in the range, count how many cells are blank
For Each Cell In Rng1
    If Cell.Value = "" Then Let errflag = errflag + 1
Next Cell
 
' If all 3 cells are blank then turn yellow and display message
 If errflag = 3 Then
    Rng1.Interior.Color = RGB(255, 255, 0) ' Yellow
    MsgBox "Audit Form Incompete. Please review highlighted question(s)."

'otherwise turn range to 'No Fill'
 Else
    Rng1.Interior.Pattern = xlNone ' No Fill
 End If

Stacey · Answer

Good morning, and thanks for all your help thus far. I have tried the coding you have provided to me but I am still having a problem.

The coding isn't working properly for multiple ranges.
Example: If I use the following coding with the range for one question (I11:K11) the coding works as it should:

Sub Submit()
Dim Rng1 As Range
Dim Cell As Range
Dim errflag As Integer

Set Rng1 = Sheets("Monitoring_Form").Range("I11:K11")

Let errflag = 0

' For each cell in the range, count how many cells are blank
For Each Cell In Rng1
    If Cell.Value = "" Then Let errflag = errflag + 1
Next Cell
 
' If all 3 cells are blank then turn yellow and display message
 If errflag = 3 Then
    Rng1.Interior.Color = RGB(255, 255, 0) ' Yellow
    MsgBox "Audit Form Incompete. Please review highlighted question(s)."

'otherwise turn range to 'No Fill'
 Else
    Rng1.Interior.Pattern = xlNone ' No Fill
 End If

End Sub


but if I try to add multiple questions using a broader range such as I11:K16 the coding does not work appropriately. I changed the errflag=3 to errflag=18. I would get the error message but if I answered one of the questions the remaining questions would also turn back to the regular color. Meaning that the coding is recognizing the ranges as one. Below is the coding I used trying to add multiple ranges:

Dim Rng1 As Range
Dim Cell As Range
Dim errflag As Integer

Set Rng1 = Sheets("Monitoring_Form").Range("I11:K16,I19:K24,I27:K34,H40:K44,H47:K51")

Let errflag = 0

' For each cell in the range, count how many cells are blank
For Each Cell In Rng1
    If Cell.Value = "" Then Let errflag = errflag + 1
Next Cell
 
' If all 3 cells are blank then turn yellow and display message
 If errflag = 18 Then
    Rng1.Interior.Color = RGB(255, 255, 0) ' Yellow
    MsgBox "Audit Form Incompete. Please review highlighted question(s)."

'otherwise turn range to 'No Fill'
 Else
    Rng1.Interior.Pattern = xlNone ' No Fill
 End If


Keep in mind this is only for section 1 with the 3 answers provided.

Thanks for all your help!

RayH · Answer

I've designed this to be as flexiable as possible.
There are two routines. One Sub and one function.

There is a  routine that calls it. I've called it 'runit'
The Check_Answers sub goes down thorugh the questions and for each calls a function called 'HighlightRow'. This function checks the responses and determines whether they have made a choice. If not, the row is highlighted yellow otherwise the yellow is removed.

The Check_Answers sub needs FOUR parameters passed to it.
The starting row and starting column, the number of questions and the number of answers.


Dim Err As Boolean
Dim msgflag As Boolean

Sub Check_Answers(RowStart As Long, ColumnStart As Long, NumberofQuestions As Integer, NumberofAnswers As Integer)
Dim myRow As Long
Dim myColumn As Long

Let myRow = RowStart
Let myColumn = ColumnStart

For myRow = myRow To myRow + NumberofQuestions - 1
    Err = HighlightRow(myRow, myColumn, NumberofAnswers)

    If Err And Not msgflag Then Let msgflag = True
Next myRow

End Sub


Function HighlightRow(qRow As Long, qcolumn As Long, NumberofAnswers)
' This function turns the row Yellow if all are left blank

Dim errflag As Integer
Dim testcol As Long
Let errflag = 0

' For each cell in the range, count how many cells are blank
For testcol = qcolumn To qcolumn + NumberofAnswers - 1
  If Cells(qRow, testcol).Value = "" Then Let errflag = errflag + 1
Next testcol

If errflag = NumberofAnswers Then
    ' Turn of row highlight (yellow)
        Range(Cells(qRow, qcolumn), Cells(qRow, qcolumn + NumberofAnswers - 1)).Interior.Color = RGB(255, 255, 0) ' Yellow
        HighlightRow = True
Else
    ' Turn off row highlight
        Range(Cells(qRow, qcolumn), Cells(qRow, qcolumn + NumberofAnswers - 1)).Interior.Pattern = xlNone ' No Fill
        HighlightRow = False
End If
End Function

Sub runit()
Let Err = False
Let msgflag = False

' Check answers starting from row 2 and column 2 for 20 questions with 3 answers each
' Cell B2
Check_Answers 2, 2, 20, 3

' Check answers starting from row 24 and column 2 for 30 questions with 4 answers each
' Cell B24
Check_Answers 24, 2, 30, 4

' Display msg if any of the answers are blanks (covers both sections)
If msgflag Then MsgBox "Audit Form Incompete. Please review highlighted question(s)."

End Sub

How to evaluate a range of cells in VB?

8 responses

Similar discussions

Subscribe To Our Newsletter!