VBA code to highlight empty cells that are mandatory

[kaz123]

Hello


I needed help with identifying all required data that has been left blank. I have multiple workbooks and within each workbook there are multiple worksheets, all have employee related rows of data. I wanted a macro/vba script to be able to automatically go through each worksheets within the workbook and then highlight each required missing cells in yellow. To identify what is mandatory or optional there will be a cell below the column heading that states this.

Please see below example of a spreadsheet of how I want it to look. The cells highlighted in yellow are what is missing required data that have not been populated, this is what I need VBA to do. My workbooks contains many worksheets and each has many columns and rows of data so manually doing this or through conditional formatting is very time consuming.

Additionally, if I could run the macro from a separate workbook which allows me to open each workbook to run the code against that would be even better then having to copy and paste the macro in each workbook.

Any assistance will be greatly appreciated.

Thanks

 

[Akuini]

I assume the header is at row 1.
Try:

Sub kaz123()

Dim ws As Worksheet
Dim c As Range
Dim sAddress As String, n As Long
Application.ScreenUpdating = False

For Each ws In ActiveWorkbook.Worksheets
n = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ws.Rows(2)
    Set c = .Find(What:="Mandatory", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not c Is Nothing Then
        sAddress = c.Address
        Do
           On Error Resume Next
           ws.Range(ws.Cells(3, c.Column), ws.Cells(n, c.Column)).SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
           On Error GoTo 0
           Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> sAddress
    End If
End With

Next
Application.ScreenUpdating = True
End Sub

 

[kaz123]

I assume the header is at row 1.
Try:

Sub kaz123()

Dim ws As Worksheet
Dim c As Range
Dim sAddress As String, n As Long
Application.ScreenUpdating = False

For Each ws In ActiveWorkbook.Worksheets
n = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ws.Rows(2)
    Set c = .Find(What:="Mandatory", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not c Is Nothing Then
        sAddress = c.Address
        Do
           On Error Resume Next
           ws.Range(ws.Cells(3, c.Column), ws.Cells(n, c.Column)).SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
           On Error GoTo 0
           Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> sAddress
    End If
End With

Next
Application.ScreenUpdating = True
End Sub

Thank you very much, I will have a look at this and come back.

 

[kaz123]

Thanks, this works very nicely. One quick question, if the rows with the Mandatory identifier was different for some worksheets I'm guessing I will need to amend below code to search for the first row that has the word "Mandatory"

With ws.Rows(2)

 

[Akuini]

I'm guessing I will need to amend below code to search for the first row that has the word "Mandatory"

Try:

Sub kaz123_v2()

Dim ws As Worksheet
Dim c As Range, f As Range
Dim sAddress As String, n As Long
Application.ScreenUpdating = False

For Each ws In ActiveWorkbook.Worksheets
n = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set f = ws.Cells.Find(What:="Mandatory", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not f Is Nothing Then

    With ws.Rows(f.Row)
        Set c = .Find(What:="Mandatory", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            sAddress = c.Address
            Do
               On Error Resume Next
               ws.Range(ws.Cells(3, c.Column), ws.Cells(n, c.Column)).SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
               On Error GoTo 0
               Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> sAddress
        End If
    End With
End If

Next
Application.ScreenUpdating = True
End Sub

 

[kaz123]

Brilliant. Thank you, much appreciated.

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.