Compare two columns from which one column is not mandatory - excel

Question

I need help for a macro code.
In my case the excel macro checks data in one sheet ("Check_file") for completeness and correctness.
There are mandatory columns in the sheet which have to exist and also not-mandatory columns can exist.
In my example the columns “company” and “fee” are mandatory columns, if they are missing or false the macro will throw an error.
Next to them, the column “gross fee” is not-mandatory and its data should only be checked with the data in column “fee”, if column “gross fee” exists. If it exists, the amount should be the same as in column “fee”. If it doesnt exist, there should be no comparison.
The check for the mandatory columns works fine within a For-Loop and an own Range.
My problem is that I dont know how I can involve the not-mandatory columns into the loop of the mandatory columns…
I tried to define a separate Range for the not-mandatory columns area. But it seems that I cannnot create the connection to the not-mandatory column if it is not set in the mandatory columns loop. But if it is set to the mandatory columns range and the not-mandatory column doesnt exist, an error will be thrown.
Should the exist-check for the not-mandatory columns be placed in a separate Sub or Function? If yes, how can the connection be created to the mandatory check Range?
This is the vba code:
Function Main_Check(ByVal StrFilePath As String) As String
'//Checks all criteria for the correct filling of the template. Marks all fields that are incorrectly
filled in red.
Dim WB As Workbook, WS As Worksheet
Dim i As Long, iNotMand As Long, lEnde As Long, strHeader As String, ii As Long, lColEnde As Long
Dim rngFind As Range, booCheck As Boolean, rngHeader As Range, rngKey As Range, rngUsed As Range,
rngHeaderNotMand As Range, rngFindNotMand As Range, rngKeyGrossFee As Range, rngGrossFee As Range
Dim strKey As String, arrKey As String, strKeyGrossFee As String, strGrossFee As String
On Error GoTo ErrorHandler
If StrFilePath = “” Then GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'//Template is opened
Set WB = Workbooks.Open(StrFilePath)
Set WS = WB.Worksheets(“Check_file”)
With WS
.Cells.EntireColumn.AutoFit
'//Stores the last row and column to be processed
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
lColEnde = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
'//Find the beginning of the table
Set rngFind = .Cells.Find(what:=Settings.Cells(Settings.Range("Header_Start").Row + 1, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngFind Is Nothing Then
booCheck = False
End
End If
.Range(rngFind.Address, .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row,
rngFind.Column)).EntireRow.Hidden = False
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
'//booCheck is set to true and on error to false _
Thus, if "True" is passed, the complete file is correct
Set rngUsed = .Range(rngFind.Address, .Cells(lEnde, lColEnde))
booCheck = IsErrorAll(rngUsed)
'//Header Check _
Checks all headers in advance to see if they are present and writes the missing ones in a cell
.Cells(4, 7).Clear
.Cells(4, 8).Clear
For i = Settings.Range("Header_Start").Row + 1 To Settings.Range("Header_Ende").Row - 1
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=Settings.Cells(i, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngHeader Is Nothing Then
booCheck = False
.Cells(4, 7).Value = "The following column labels were not found: "
If .Cells(4, 8).Value = "" Then
.Cells(4, 8).Value = .Cells(4, 8).Value & Settings.Cells(i, 2).Value
Else
.Cells(4, 8).Value = "," & .Cells(4, 8).Value & Settings.Cells(i, 2).Value
End If
.Cells(4, 8).Interior.Color = vbRed
Else
End If
Next i
If booCheck = False Then GoTo Ende
'// Check Not-Mandatory Columns _
Checks in advance whether Not-mandatory columns are available
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
For iNotMand = Settings.Range("NotMand_Start").Row + 1 To Settings.Range("NotMand_Ende").Row - 1
Set rngHeaderNotMand = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=Settings.Cells(iNotMand, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rngHeaderNotMand Is Nothing Then
'//Not-mandatory columns are defined
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Else
strKeyGrossFee = ""
End If
'//All line items are run through and the individual criteria are checked
For i = rngFind.Row + 1 To lEnde Step 1
'//Company
strKey = "Company"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
iCoi = rngHeader.Column
If .Cells(i, rngHeader.Column).Value Like "####" Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
Else
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
End If
'//Fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngHeader.Column).Value Like "*,*" Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
'//Gross fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Set rngGrossFee = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=strGrossFee, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngGrossFee.Column).Value Is Nothing Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
ElseIf .Cells(i, rngHeader.Column).Value <> .Cells(i, rngGrossFee.Column).Value Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
Next i
End With
'//Define results
Ende:
Main_Check = booCheck & “,” & Replace(CStr(rngFind.Address), “$”, “”)
If booCheck = False Then
WS.Cells(7, 7).Value = “Error counter:”
WS.Cells(7, 8).Value = WS.Cells(7, 8).Value + 1
Else
WS.Cells(7, 7).Value = “Check ok”
WS.Cells(7, 8).Value = “”
End If
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Function
'//If there are other errors, it should exit here and return ERROR
ErrorHandler:
On Error GoTo -1
On Error Resume Next
Main_Check = “ERROR”
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function

Answer 1

I would recommend you refactor your code into 3 parts. 1- read the settings, 2- profile the sheet and then 3- check the data. Debug each step in turn.
Function Main_Check2(ByVal StrFilePath As String) As String
Const CHECK = "Check_file"
Dim wb As Workbook, ws As Worksheet, arHdr
Dim booCheck As Boolean, bExists As Boolean
Dim iColFee As Long, i As Long, msg As String
' check valid filepath
If Dir(StrFilePath) = "" Then
msg = "'" & StrFilePath & "' does not exist"
MsgBox msg, vbCritical, "File not found"
Main_Check2 = msg
Exit Function
End If
' open file and check sheet exists
Set wb = Workbooks.Open(StrFilePath)
bExists = False
For Each ws In wb.Sheets
If ws.Name = CHECK Then
bExists = True
Exit For
End If
Next
If Not bExists Then
msg = "Sheet '" & CHECK & "' not found in " & wb.FullName
MsgBox msg, vbCritical, "Sheet not found"
wb.Close False
Exit Function
End If
' get header details from settings sheet
Call GetSettings(Settings, arHdr)
' check headers, find fee column
booCheck = CheckHeaders(ws, arHdr, iColFee)
'Call DumpArray(arHdr) ' check results so far
' exit if false
If booCheck = False Then
Main_Check2 = booCheck
Exit Function
End If
' check data
With ws
'//All line items are run through and the individual criteria are checked
Dim rngData As Range, sName As String, n As Long
Dim iRow As Long, iCol As Long, lastrow As Long, cell As Range
For i = 1 To UBound(arHdr)
sName = arHdr(i, 1) ' header name
iCol = arHdr(i, 4) ' header column
iRow = arHdr(i, 5) ' header row
n = arHdr(i, 6) ' number of rows
' scan column
If iCol > 0 And n > 0 Then
Set rngData = .Cells(iRow + 1, iCol).Resize(n)
Select Case sName
Case "Company"
For Each cell In rngData
If cell.Value Like "####" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Fee"
For Each cell In rngData
If Not cell.Value Like "*,*" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Gross Fee"
' optional - skipped if icol = 0
For Each cell In rngData
If Len(cell) = 0 Then
cell.Interior.Pattern = xlNone
ElseIf cell.Value <> .Cells(cell.Row, iColFee).Value Then
cell.Interior.Color = vbRed
booCheck = False
Else
cell.Interior.Pattern = xlNone
End If
Next
End Select
End If
Next
End With
'//Define results
Ende:
If booCheck = False Then
ws.Cells(7, 7).Value = "Error counter:"
ws.Cells(7, 8).Value = ws.Cells(7, 8).Value + 1
Else
ws.Cells(7, 7).Value = "Check ok"""
ws.Cells(7, 8).Value = ""
End If
'wb.Close True
Main_Check2 = booCheck '& "," & Replace(CStr(rngFind.Address), "$", "")
End Function
Function GetSettings(ws, ByRef arHdr) As Boolean
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long
Dim n As Long, m As Long, i As Long, msg As String
With ws
r1 = .Range("Header_Start").Row
r2 = .Range("Header_Ende").Row
r3 = .Range("NotMand_Start").Row
r4 = .Range("NotMand_Ende").Row
m = r2 - r1 - 1 ' mandatory header
n = r4 - r3 - 1 ' non-mandatory headers
If m < 1 Then
msg = "No mandatory headers on setting"
MsgBox msg, vbExclamation, "Settings Error"
getSettings = False
End If
' size array and fill
ReDim arHdr(1 To n + m, 1 To 6)
For i = 1 To m
arHdr(i, 1) = .Cells(r1 + i, 1)
arHdr(i, 2) = .Cells(r1 + i, 2) ' search term
If Len(arHdr(i, 2)) > 0 Then ' skip blanks
arHdr(i, 3) = True ' mandatory
Else
arHdr(i, 3) = False
End If
Next
For i = 1 To n
arHdr(m + i, 1) = .Cells(r3 + i, 1)
arHdr(m + i, 2) = .Cells(r3 + i, 2)
arHdr(m + i, 3) = False ' optional
Next
End With
getSettings = True
End Function
Function CheckHeaders(ws, ByRef arHdr, ByRef iColFee) As Boolean
'//Header Check
'Checks all headers in advance to see if they are present
'and writes the missing ones in a cell
Dim rngTable As Range, rng As Range
Dim msg As String, sHdr As String, sTableStart As String
Dim i As Long, lastrow As Long, rowHdr As Long
Dim booCheck As Boolean
' search value for column 1 of table
sTableStart = arHdr(1, 2)
With ws
'//Find the beginning of the table
Set rngTable = .Cells.Find(what:=sTableStart, LookIn:=xlValues, lookat:=xlWhole)
If rngTable Is Nothing Then
msg = "Could not find begining of table '" & sTableStart & "'"
MsgBox msg, vbExclamation, "Error"
CheckHeaders = False
Exit Function
Else
rowHdr = rngTable.Row
End If
For i = 1 To UBound(arHdr)
sHdr = Trim(arHdr(i, 2))
If Len(sHdr) > 0 Then ' skip blanks
Set rng = .Rows(rowHdr).Find(what:=sHdr, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
arHdr(i, 4) = 0
Else
' store fee column for later gross fee check
If arHdr(i, 1) = "Fee" Then iColFee = rng.Column
arHdr(i, 4) = rng.Column
arHdr(i, 5) = rng.Row
lastrow = .Cells(.Rows.Count, rng.Column).End(xlUp).Row
arHdr(i, 6) = lastrow - rng.Row - 1 ' data rows
End If
Else
arHdr(i, 4) = 0
End If
Next
' check for mandatory column errors
Dim sep As String
For i = 1 To UBound(arHdr)
If arHdr(i, 3) And arHdr(i, 4) = 0 Then
msg = msg & sep & arHdr(i, 2)
sep = ","
End If
Next
If Len(msg) > 0 Then
.Cells(4, 7) = "The following column labels were not found: "
.Cells(4, 8) = msg
.Cells(4, 8).Interior.Color = vbRed
CheckHeaders = False
'GoTo Ende
Else
.Cells(4, 7).Clear ' G4
.Cells(4, 8).Clear ' H4
CheckHeaders = True
End If
End With
End Function
' dump array to new workbook to debug
Sub DumpArray(ar)
Dim wb As Workbook: Set wb = Workbooks.Add
With wb.Sheets(1)
.Name = "arHdr"
.Range("A1:F1") = Array("Header1", "Header2", "Mandatory", "Column", "Row", "DataRows")
.Range("A2").Resize(UBound(ar), UBound(ar, 2)) = ar
End With
' save - replace existing
Application.DisplayAlerts = False
wb.SaveAs "debug_arHdr.xlsx"
Application.DisplayAlerts = True
'wb.Close
End Sub