We help IT Professionals succeed at work.
Get Started

VBA error subscript out of range help

169 Views
Last Modified: 2017-05-11
Hi,

i got this code from mrexcel

when i run the code, the debugger stops at Set wsOld = GetWorksheet(WSName:=msaCompareSheets(0), WB:=mwbOld)  error subscript out of range.  i tried to find the issue, but could not fix it, i think the issue is in the sheet name somehow but my eyes cannot find what is causing it.

i have uploaded the workbook that has the whole setup and code.

Dim mbaKeyFields() As Boolean
Dim mbaKeyCols1() As Boolean
Dim mbaKeyCols2() As Boolean
Dim mbaHeadingsInfo() As Boolean
Dim mbIgnoreCase As Boolean
Dim mbDisplayOutputHeadings As Boolean
Dim mbFilterKey As Boolean
Dim mbShowUnchangedCells As Boolean

Dim miMaxColumns As Integer
Dim miaHeadingCols1() As Integer
Dim miaHeadingCols2() As Integer
Dim miaKeyFields1() As Integer
Dim miaKeyFields2() As Integer

Const mlResultsPtrDupKey1 As Long = 1
Const mlResultsPtrDupKey2 As Long = 2
Const mlResultsPtrMismatched As Long = 3
Const mlResultsPtrMatched As Long = 4
Const mlResultsPtrData1Only As Long = 5
Const mlResultsPtrData2Only As Long = 6

Dim mlReportRow As Long
Dim mlaResultsSheetsPtrs(1 To 6) As Long

Dim msIgnoreCharacters As String
Dim msOnlyCharacters As String
Dim msaCompareSheets() As String
Dim msResultsSheet As String
Dim msaHeadings1() As String
Dim msaHeadings2() As String
Dim msaHeadingRows() As String
Dim msaResultsSheets(1 To 6) As String

Dim mvaDuplicateKeys As Variant

Dim mwbOld As Workbook
Dim mwbNew As Workbook

Dim mwsReportSheet As Worksheet
Dim mwsaResultsSheets(1 To 6) As Worksheet

Sub CompareSheets()
Dim bChanged As Boolean, baChanged() As Boolean

Dim iColEnd As Integer, iCol As Integer, iCol1 As Integer, iCol2 As Integer

Dim lSheetPtr As Long
Dim lRow1 As Long
Dim lRow2 As Long
Dim lHeadingRow1 As Long
Dim lHeadingRow2 As Long

Dim objDictOld As Object, objDictNew As Object

Dim sCompareString1 As String
Dim sCompareString2 As String

Dim vKeys As Variant, vKey As Variant
Dim vaInput() As Variant, vaOutput() As Variant, vaOutput2() As Variant
Dim vaInputOld As Variant, vaInputNew As Variant
Dim vaHeadings() As Variant

Dim wsOld As Worksheet, wsNew As Worksheet

mlDuplicateKeysCount = 0
mlReportRow = 0

If GetParameters = False Then Exit Sub

For lSheetPtr = 1 To UBound(mwsaResultsSheets)
    Set mwsReportSheet = mwsaResultsSheets(lSheetPtr)
    If Not (mwsReportSheet Is Nothing) Then
        With mwsReportSheet.Cells
            .ClearFormats
            .ClearContents
        End With
        If mbDisplayOutputHeadings = True Then
            ReDim vaHeadings(1 To 1, 1 To UBound(msaHeadings1) + 2)
            For iCol = 0 To UBound(msaHeadings1)
                If msaHeadings1(iCol) = msaHeadings2(iCol) Then
                    vaHeadings(1, iCol + 2) = msaHeadings1(iCol)
                Else
                    vaHeadings(1, iCol + 2) = msaHeadings1(iCol) & " / " & msaHeadings2(iCol)
                End If
            Next iCol
            mwsReportSheet.Range("A1", mwsReportSheet.Cells(1, UBound(vaHeadings, 2)).Address).Value = vaHeadings
            mwsReportSheet.CustomProperties.Item(1).Value = 1
        Else
            mwsReportSheet.CustomProperties.Item(1).Value = 0
        End If
    End If
Next lSheetPtr

lHeadingRow1 = Val(msaHeadingRows(0))
If lHeadingRow1 < 1 Then lHeadingRow1 = 1

lHeadingRow2 = Val(msaHeadingRows(UBound(msaHeadingRows)))
If lHeadingRow2 < 1 Then lHeadingRow2 = 1

Set wsOld = GetWorksheet(WSName:=msaCompareSheets(0), WB:=mwbOld)
If wsOld Is Nothing Then Exit Sub

If PopulateHeadingColumns(WS:=wsOld, _
                          HeadingsTexts:=msaHeadings1, _
                          HeadingsColumns:=miaHeadingCols1, _
                          HeadingRow:=lHeadingRow1, _
                          KeyColumns:=miaKeyFields1) = False Then
    Exit Sub
End If

Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrDupKey1)

miMaxColumns = UBound(msaHeadings1) + 1
Set objDictOld = PopulateDictionary(WS:=wsOld, _
                                    KeyColumns:=miaKeyFields1, _
                                    HeadingRow:=lHeadingRow1, _
                                    ReportSheet:=mwsReportSheet, _
                                    ColumnPositions:=miaHeadingCols1)
If objDictOld Is Nothing Then
    Exit Sub
End If

On Error Resume Next
mwbOld.Close savechanges:=False
On Error GoTo 0

Set wsNew = GetWorksheet(WSName:=msaCompareSheets(1), WB:=mwbNew)
If wsNew Is Nothing Then Exit Sub

If PopulateHeadingColumns(WS:=wsNew, _
                          HeadingsTexts:=msaHeadings2, _
                          HeadingsColumns:=miaHeadingCols2, _
                          HeadingRow:=lHeadingRow2, _
                          KeyColumns:=miaKeyFields2) = False Then
    Exit Sub
End If

Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrDupKey2)
Set objDictNew = PopulateDictionary(WS:=wsNew, _
                                    KeyColumns:=miaKeyFields2, _
                                    HeadingRow:=lHeadingRow2, _
                                    ReportSheet:=mwsReportSheet, _
                                    ColumnPositions:=miaHeadingCols2)
If objDictNew Is Nothing Then
    Exit Sub
End If

On Error Resume Next
mwbNew.Close savechanges:=False
On Error GoTo 0

vKeys = objDictOld.Keys
For Each vKey In vKeys
    ReDim vaInputOld(1 To 1, 1 To miMaxColumns + 1)     ' Mar 2017
    vaInputOld = objDictOld.Item(vKey)
    If objDictNew.Exists(vKey) Then
        ReDim vaInputNew(1 To 1, 1 To miMaxColumns + 1) ' Mar 2017
        vaInputNew = objDictNew.Item(vKey)
        ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
        ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
        ReDim baChanged(1 To miMaxColumns)
        bChanged = False
        For iCol = 1 To miMaxColumns
            vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
            sCompareString1 = AdjustStringForComparison(InputString:=vaInputOld(1, iCol))
            sCompareString2 = AdjustStringForComparison(InputString:=vaInputNew(1, iCol))
            If sCompareString1 <> sCompareString2 Then
                vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
                If mbaHeadingsInfo(iCol - 1) = False Then
                    baChanged(iCol) = True
                    bChanged = True
                End If
            Else
                If mbShowUnchangedCells = True Then
                    vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
                End If
            End If
        Next iCol
        
        If bChanged Then
            Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrMismatched)
            If Not (mwsReportSheet Is Nothing) Then
                mlReportRow = mwsReportSheet.CustomProperties.Item(1).Value
                mlReportRow = mlReportRow + 1
                For iCol = 1 To UBound(baChanged)
                    If baChanged(iCol) Then
                        With mwsReportSheet
                            .Range(.Cells(mlReportRow, iCol + 1).Address, _
                                   .Cells(mlReportRow + 1, iCol + 1).Address).Interior.Color = vbYellow
                        End With
                    End If
                Next iCol
            
                vaOutput(1, 1) = "Changed: Row " & vaInputOld(1, UBound(vaInputOld, 2))
                vaOutput2(1, 1) = "_______:  Row " & vaInputNew(1, UBound(vaInputNew, 2))
                
                With mwsReportSheet
                    .Range(.Cells(mlReportRow, 1).Address, _
                           .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput
                    mlReportRow = mlReportRow + 1
                    .Range(.Cells(mlReportRow, 1).Address, _
                           .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput2
                End With
                
                mwsReportSheet.CustomProperties.Item(1).Value = mlReportRow
                
            End If              'If Not (mwsReportSheet Is Nothing) Then
            
        Else                    'If bChanged Then
        
            Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrMatched)
            If Not (mwsReportSheet Is Nothing) Then
                mlReportRow = mwsReportSheet.CustomProperties.Item(1).Value
                mlReportRow = mlReportRow + 1
                mwsReportSheet.CustomProperties.Item(1).Value = mlReportRow
                
                vaOutput(1, 1) = "No Change: Row " & vaInputOld(1, UBound(vaInputOld, 2)) & _
                                 ", Row " & vaInputNew(1, UBound(vaInputNew, 2))
                With mwsReportSheet
                    .Range(.Cells(mlReportRow, 1).Address, _
                           .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput
                End With
            End If
        End If                  'If bChanged Then
        
        objDictOld.Remove vKey
        objDictNew.Remove vKey
    Else                            'If objDictNew.Exists(vKey) Then
        Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrData1Only)
        If Not (mwsReportSheet Is Nothing) Then
            mlReportRow = mwsReportSheet.CustomProperties.Item(1)
            mlReportRow = mlReportRow + 1
            mwsReportSheet.CustomProperties.Item(1).Value = mlReportRow
            ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
            vaOutput(1, 1) = "Only " & msaCompareSheets(0) & " Row " & vaInputOld(1, UBound(vaInputOld, 2))
            For iCol = 1 To miMaxColumns
                vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
            Next iCol
            
            With mwsReportSheet
                .Range(.Cells(mlReportRow, 1).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput
                '-- Set the row to light grey
                .Range(.Cells(mlReportRow, 2).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 15
            End With
        End If
    End If                          'If objDictNew.Exists(vKey) Then
Next vKey

If objDictNew.Count <> 0 Then
    vKeys = objDictNew.Keys
    For Each vKey In vKeys
        Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrData2Only)
        If Not (mwsReportSheet Is Nothing) Then
            mlReportRow = mwsReportSheet.CustomProperties.Item(1)
            mlReportRow = mlReportRow + 1
            mwsReportSheet.CustomProperties.Item(1).Value = mlReportRow
            ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
            vaInputNew = objDictNew.Item(vKey)
            vaOutput2(1, 1) = "Only " & msaCompareSheets(1) & " Row " & vaInputNew(1, UBound(vaInputNew, 2))
            For iCol = 1 To miMaxColumns
                vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
            Next iCol
            With mwsReportSheet
                .Range(.Cells(mlReportRow, 1).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput2
                '-- Set the row to light green
                .Range(.Cells(mlReportRow, 2).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 4
            End With
        End If
    Next vKey
End If


For lPtr = 1 To UBound(mwsaResultsSheets)
    Set mwsReportSheet = mwsaResultsSheets(lPtr)
    SetResultsSheetColumnWidths WS:=mwsReportSheet
Next lPtr

objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub

Private Sub SetResultsSheetColumnWidths(ByVal WS As Worksheet)
Dim lEndCol As Long
Dim saColumns() As String

On Error GoTo 0
If WS Is Nothing Then
Else
    WS.Calculate
    WS.Columns("A:A").ColumnWidth = 30
    lEndCol = WS.UsedRange.Columns.Count
    saColumns = Split(WS.Cells(1, lEndCol).Address(True, True), "$")
    WS.Columns("B:" & saColumns(1)).EntireColumn.AutoFit
End If

End Sub

Private Function AdjustStringForComparison(ByVal InputString As String) As String
Dim lPtr As Long

Dim sChar As String
Dim sResult As String

If mbIgnoreCase = True Then
    InputString = LCase$(InputString)
End If

If Len(msOnlyCharacters) = 0 Then
    sResult = InputString
Else
    If mbIgnoreCase = True Then
        msOnlyCharacters = LCase$(msOnlyCharacters)
    End If
    For lPtr = 1 To Len(InputString)
        sChar = Mid$(InputString, lPtr, 1)
        If InStr(msOnlyCharacters, sChar) > 0 Then
            sResult = sResult & sChar
        End If
    Next lPtr
End If

If Len(msIgnoreCharacters) > 0 Then
    If mbIgnoreCase = True Then
        msIgnoreCharacters = LCase$(msIgnoreCharacters)
    End If
    For lPtr = 1 To Len(msIgnoreCharacters)
        sChar = Mid$(msIgnoreCharacters, lPtr, 1)
        sResult = Replace(sResult, sChar, "")
    Next lPtr
End If

AdjustStringForComparison = sResult

End Function

Private Function GetResultsWorksheet(ByVal WSName As String) As Worksheet
Dim lSheetsCount As Long
Dim sWSNumber As String

If Replace(LCase$(WSName), " ", "") = "<>" Then
    Set GetResultsWorksheet = Nothing
Else
    On Error Resume Next
    Set GetResultsWorksheet = ThisWorkbook.Sheets(WSName)
    On Error GoTo 0
    If (GetResultsWorksheet Is Nothing) Then
        lSheetsCount = ThisWorkbook.Sheets.Count
        With ThisWorkbook
            lSheetsCount = .Sheets.Count
            Set GetResultsWorksheet = .Sheets.Add(after:=.Sheets(lSheetsCount))
        End With
        On Error Resume Next
        Err.Number = 0
        GetResultsWorksheet.Name = WSName
        If Err.Number > 0 Then
            MsgBox prompt:="Invalid sheet name '" & WSName & "'. Data being sent to sheet '" & _
                            GetResultsWorksheet.Name & "'", _
                    Buttons:=vbOKOnly + vbExclamation
        End If
    End If
    If Not (GetResultsWorksheet Is Nothing) Then
        On Error Resume Next
        With GetResultsWorksheet.CustomProperties
            .Item(1).Value = 0
            .Add Name:="LastRowUsed", Value:=0
        End With
    End If
End If
End Function

Private Function GetWorksheet(ByVal WSName As String, ByRef WB As Workbook) As Worksheet
Dim bThisWB As Boolean
Dim iWSPtr As Integer
Dim saWorksheet() As String
Dim WBInput As Workbook

Set GetWorksheet = Nothing
saWorksheet = Split(WSName, "!")
iWSPtr = UBound(saWorksheet)

Set WBInput = Nothing
On Error Resume Next
If iWSPtr = 0 Then
    Set WBInput = ThisWorkbook
    bThisWB = True
Else
    bThisWB = False
    Set WBInput = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & saWorksheet(0), ReadOnly:=True)
    Set WB = WBInput
End If
If WBInput Is Nothing Then
    MsgBox prompt:="Unable to open '" & saWorksheet(0), Buttons:=vbOKOnly + vbCritical
    Exit Function
End If

Set GetWorksheet = WBInput.Sheets(saWorksheet(iWSPtr))
If GetWorksheet Is Nothing Then
    If bThisWB = False Then WBInput.Close savechanges:=False
    MsgBox prompt:="Unable to access worksheet '" & WSName & "'", Buttons:=vbOKOnly + vbCritical
End If
End Function
Private Function PopulateDictionary(ByRef WS As Worksheet, _
                                    ByRef KeyColumns() As Integer, _
                                    ByVal HeadingRow As Long, _
                                    ByVal ReportSheet As Worksheet, _
                                    ByRef ColumnPositions() As Integer) As Object
Dim iPtr As Integer
Dim iKeyColsPtr As Integer
Dim iKeyPtr As Integer
Dim iCurCol As Integer
Dim iColEnd As Integer

Dim lRowEnd As Long
Dim lRow As Long
Dim lErrorCount As Long
Dim lReportPtr As Long

Dim rCur As Range

Dim sKey As String
Dim sCurKey As String
Dim sText As String
Dim saCurKey() As String

Dim vaItem() As Variant
Dim vaCurRow As Variant
Dim vaReport As Variant
Dim vReply As Variant

ReDim saCurKey(LBound(KeyColumns) To UBound(KeyColumns))

With WS.UsedRange
    iColEnd = .Column + .Columns.Count - 1
End With

Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, ColumnPositions(0)).End(xlUp).Row
For lRow = HeadingRow + 1 To lRowEnd
    vaCurRow = WS.Range("A" & lRow).Resize(, iColEnd).Value
    sKey = ""
    For iKeyColsPtr = LBound(KeyColumns) To UBound(KeyColumns)
        iKeyPtr = KeyColumns(iKeyColsPtr)
        If iKeyPtr <> 0 Then
            saCurKey(iKeyColsPtr) = CStr(vaCurRow(1, iKeyPtr))
            sCurKey = LCase$(CStr(vaCurRow(1, iKeyPtr)))
            If mbFilterKey = True Then
                sCurKey = AdjustStringForComparison(sCurKey)
            End If
            sKey = sKey & "|" & sCurKey
        End If
    Next iKeyColsPtr
    If sKey = "" Then
        MsgBox prompt:="No key headings specified", _
                Buttons:=vbOKOnly + vbCritical, _
                Title:="PARAMETER ERROR"
        Set PopulateDictionary = Nothing
        Exit Function
    End If
    sKey = Mid$(sKey, 2)
    
    ReDim vaItem(1 To 1, 1 To UBound(ColumnPositions) + 2)
    For iPtr = 0 To UBound(ColumnPositions)
        iCurCol = ColumnPositions(iPtr)
        vaItem(1, iPtr + 1) = vaCurRow(1, iCurCol)
    Next iPtr
    vaItem(1, UBound(vaItem, 2)) = lRow         '-- Add row number to last element --
    
    If PopulateDictionary.Exists(sKey) Then
    
        If Not (ReportSheet Is Nothing) Then
            lDuplicateCount = lDuplicateCount + 1
            sText = "Duplicate key at row " & lRow & " of " & WS.Parent.Name & "!" & WS.Name & "."
            
            ReDim vaReport(1 To 1, 1 To UBound(vaItem, 2))
            vaReport(1, 1) = sText
            For lReportPtr = 1 To UBound(vaReport, 2) - 1
                vaReport(1, lReportPtr + 1) = vaItem(1, lReportPtr)
            Next lReportPtr

            mlReportRow = ReportSheet.CustomProperties.Item(1)
            mlReportRow = mlReportRow + 1
            ReportSheet.CustomProperties.Item(1).Value = mlReportRow
            
            With ReportSheet.Range("A" & mlReportRow).Resize(, UBound(vaReport, 2))
                .Value = vaReport
                .Characters.Font.Color = vbRed
            End With
        End If
        
    Else
        On Error Resume Next
        PopulateDictionary.Add Key:=sKey, Item:=vaItem
        If Err.Number <> 0 Then
            If MsgBox(prompt:="Error " & Err.Number & " in sheet " & WS.Name & " row " & lRow & vbCrLf & _
                                    Err.Description & vbCrLf & "Do you wish to ignore this and  continue?", _
                            Buttons:=vbYesNo + vbCritical, _
                            Title:="ERROR DETECTED") = vbNo Then
                Set PopulateDictionary = Nothing
                Exit Function
            End If
        End If
        On Error GoTo 0
    End If
Next lRow
End Function

Private Function GetParameters() As Boolean
Dim bError As Boolean
Dim iKeyFieldCount As Integer
Dim iPtr As Integer
Dim iParamCheck As Integer
Const iParamCompareSheets As Integer = 1
Const iParamResultsSheet As Integer = 2
Const iParamHeadings As Integer = 4

Dim lRow As Long
Dim sCurKey As String
Dim saCurInput() As String
Dim saHeadings() As String, saHeadingsA() As String
Dim vaParameters As Variant
Dim vaArrayResultsParams As Variant

Dim wsParams As Worksheet, wsTemp As Worksheet

On Error Resume Next
For iPtr = 1 To UBound(mwsaResultsSheets)
    Set mwsaResultsSheets(iPtr) = Nothing
Next iPtr
On Error GoTo 0

Set wsParams = Nothing
On Error Resume Next
Set wsParams = Sheets("Parameters")
On Error GoTo 0
If wsParams Is Nothing Then
    MsgBox prompt:="Cannot access 'Parameters' sheet", _
            Buttons:=vbOKOnly + vbCritical, _
            Title:="ERROR"
    GetParameters = False
    Exit Function
End If

lRow = wsParams.Cells(Rows.Count, "A").End(xlUp).Row
vaParameters = wsParams.Range("A1:B" & lRow).Value

ReDim msaHeadingRows(0 To 0)
msaHeadingRows(0) = "1"

mbDisplayOutputHeadings = True

iParamCheck = 0
For lRow = 2 To UBound(vaParameters, 1)
    sCurKey = NormaliseText(CStr(vaParameters(lRow, 1)))
    Select Case sCurKey
    Case "comparesheets"
        iParamCheck = iParamCheck Or iParamCompareSheets
        msaCompareSheets = Split(CStr(vaParameters(lRow, 2)), ",")
        If UBound(msaCompareSheets) <> 1 Then
            MsgBox prompt:="'Compare Sheets' parameter must have exactly two elements", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
        End If
        
        For iPtr = 0 To 1
            msaCompareSheets(iPtr) = Trim$(msaCompareSheets(iPtr))
            bError = msaCompareSheets(iPtr) = ""
            If bError = False Then
                saCurInput = Split(msaCompareSheets(iPtr), "!")
                bError = UBound(saCurInput) > 1
            End If
            If bError Then
                MsgBox prompt:="'Compare Sheets' parameter error", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
            End If
            
        Next iPtr
        
    Case "resultssheetduplicatekeydata1"
        Set mwsaResultsSheets(mlResultsPtrDupKey1) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
        
    Case "resultssheetduplicatekeydata2"
        Set mwsaResultsSheets(mlResultsPtrDupKey2) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
    
    Case "resultssheetmismatched"
        Set mwsaResultsSheets(mlResultsPtrMismatched) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
    
    Case "resultssheetmatched"
        Set mwsaResultsSheets(mlResultsPtrMatched) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
    
    Case "resultssheetdata1only"
        Set mwsaResultsSheets(mlResultsPtrData1Only) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
    
    Case "resultssheetdata2only"
        Set mwsaResultsSheets(mlResultsPtrData2Only) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
        
    Case "headingsrow"
        msaHeadingRows = Split(CStr(vaParameters(lRow, 2)), ",")
        
    Case "headings"
        iParamCheck = iParamCheck Or iParamHeadings
        saHeadings = Split(CStr(vaParameters(lRow, 2)), ",")
        
        ReDim msaHeadings1(0 To UBound(saHeadings))
        ReDim msaHeadings2(0 To UBound(saHeadings))
        ReDim miaHeadingCols1(0 To UBound(saHeadings))
        ReDim miaKeyFields1(0 To UBound(saHeadings))
        ReDim miaKeyFields2(0 To UBound(saHeadings))
        ReDim miaHeadingCols2(0 To UBound(saHeadings))
        ReDim mbaHeadingsInfo(0 To UBound(saHeadings))
        ReDim mbaKeyFields(0 To UBound(saHeadings))
        iKeyFieldCount = 0
        
        For iPtr = 0 To UBound(saHeadings)
            saHeadingsA = Split("=" & saHeadings(iPtr), "=")
            If UBound(saHeadingsA) < 1 Or UBound(saHeadingsA) > 2 Then
                MsgBox prompt:="Invalid headings value", Buttons:=vbOKOnly + vbCritical
                GetParameters = False
                Exit Function
            End If
            ReDim Preserve saHeadingsA(0 To 2)
            saHeadingsA(1) = Trim$(saHeadingsA(1))
            mbaHeadingsInfo(iPtr) = LCase$(Left$(saHeadingsA(1) & "123456", 6)) = "(info)"
            If mbaHeadingsInfo(iPtr) Then saHeadingsA(1) = Mid$(saHeadingsA(1), 7)
            mbaKeyFields(iPtr) = LCase$(Left$(saHeadingsA(1) & "12345", 5)) = "(key)"
            If mbaKeyFields(iPtr) Then
                iKeyFieldCount = iKeyFieldCount + 1
                saHeadingsA(1) = Mid$(saHeadingsA(1), 6)
            End If
            If saHeadingsA(2) = "" Then saHeadingsA(2) = saHeadingsA(1)
            msaHeadings1(iPtr) = saHeadingsA(1)
            msaHeadings2(iPtr) = Trim$(saHeadingsA(2))
        Next iPtr
        If iKeyFieldCount = 0 Then
            MsgBox prompt:="No key fields specified", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
        End If
        
    Case "displayoutputheadings"
        Select Case LCase$(CStr(vaParameters(lRow, 2)))
        Case "yes"
            mbDisplayOutputHeadings = True
        Case "no"
            mbDisplayOutputHeadings = False
        Case Else
            MsgBox prompt:="'Display Output Headings' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
        End Select
    
    Case "ignorecase"
        Select Case LCase$(CStr(vaParameters(lRow, 2)))
        Case "yes"
            mbIgnoreCase = True
        Case "no"
            mbIgnoreCase = False
        Case Else
            MsgBox prompt:="'Ignore Case' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
        End Select
                
    Case "filterkey"
        Select Case LCase$(CStr(vaParameters(lRow, 2)))
        Case "yes"
            mbFilterKey = True
        Case "no"
            mbFilterKey = False
        Case Else
            MsgBox prompt:="'Filter Key' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
        End Select
                       
    Case "ignorecharacters"
        msIgnoreCharacters = CStr(vaParameters(lRow, 2))
        
    Case "onlycharacters"
        msOnlyCharacters = CStr(vaParameters(lRow, 2))
    
    Case "showunchangedcells"
        Select Case LCase$(CStr(vaParameters(lRow, 2)))
        Case "yes"
            mbShowUnchangedCells = True
        Case "no"
            mbShowUnchangedCells = False
        Case Else
            MsgBox prompt:="'Show Unchanged Cells' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
            GetParameters = False
            Exit Function
        End Select
        
    Case Else
        MsgBox prompt:="Unrecognised parameter in row " & lRow, Buttons:=vbOKOnly + vbCritical
        GetParameters = False
        Exit Function
    End Select
Next lRow

GetParameters = True

'vaArrayResultsParams = Array("Results Sheet Duplicate Key Data 1", _
'                             "Results Sheet Duplicate Key Data 2", _
'                             "Results Sheet Mismatched", _
'                             "Results Sheet Matched", _
'                             "Results Sheet Data 1 Only", _
'                             "Results Sheet Data 2 Only")
'
'For lRow = 1 To UBound(mwsaResultsSheets)
'    If (mwsaResultsSheets(lRow) Is Nothing) Then
'        MsgBox prompt:="Parameter " & vaArrayResultsParams(lRow - 1) & " has an invalid value"
'        GetParameters = False
'    End If
'Next lRow

End Function

Public Function StartsWith(str As String, prefix As String) As Boolean
    StartsWith = Left(str, Len(prefix)) = prefix
End Function

Private Function PopulateHeadingColumns(ByVal WS As Worksheet, _
                                        ByRef HeadingsTexts() As String, _
                                        ByRef HeadingsColumns() As Integer, _
                                        ByVal HeadingRow As Long, _
                                        ByRef KeyColumns() As Integer) As Boolean
Dim bFound As Boolean
Dim iPtrCol As Integer, iPtrHeading As Integer, iColEnd As Integer
Dim sCurHeading As String, sCur As String
Dim vaHeadings() As Variant

iColEnd = WS.Cells(HeadingRow, Columns.Count).End(xlToLeft).Column
vaHeadings = WS.Range("A" & HeadingRow & ":" & WS.Cells(HeadingRow, iColEnd).Address).Value

For iPtrHeading = LBound(HeadingsTexts) To UBound(HeadingsTexts)
    sCurHeading = NormaliseText(HeadingsTexts(iPtrHeading))
    bFound = False
    For iPtrCol = 1 To UBound(vaHeadings, 2)
        If sCurHeading = NormaliseText(CStr(vaHeadings(1, iPtrCol))) Then
            HeadingsColumns(iPtrHeading) = iPtrCol
            If mbaKeyFields(iPtrHeading) = True Then KeyColumns(iPtrHeading) = iPtrCol
            bFound = True
            Exit For
        End If
    Next iPtrCol
    If bFound = False Then
        MsgBox prompt:="Heading '" & HeadingsTexts(iPtrHeading) & "' not found in sheet '" & WS.Name, _
                Buttons:=vbOKOnly + vbCritical
                PopulateHeadingColumns = False
                Exit Function
    End If
Next iPtrHeading

PopulateHeadingColumns = True
End Function

Private Function NormaliseText(ByVal TextString As String) As String
'-- Convert to lower case and remove all but alphanumerics --
Dim iPtr As Integer
Dim sHold As String
Dim sChar As String
Dim sResult As String

sHold = Replace(LCase$(TextString), " ", "")
sResult = ""
For iPtr = 1 To Len(sHold)
    sChar = Mid$(sHold, iPtr, 1)
    If IsNumeric(sChar) Or sChar <> UCase$(sChar) Then
        sResult = sResult & sChar
    End If
Next iPtr
NormaliseText = sResult
End Function

Open in new window

Book1.xlsb
Comment
Watch Question
CERTIFIED EXPERT
Top Expert 2016
Commented:
This problem has been solved!
Unlock 3 Answers and 5 Comments.
See Answers
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE