asked on VBA error subscript out of range help
Hi,
i got this code from mrexcel
when i run the code, the debugger stops at Set wsOld = GetWorksheet(WSName:=msaCo
i have uploaded the workbook that has the whole setup and code.
i got this code from mrexcel
when i run the code, the debugger stops at Set wsOld = GetWorksheet(WSName:=msaCo
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
VBAMicrosoft ExcelMicrosoft Office
Last Comment
Flora Edwards
SOLUTION
THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
SOLUTION
THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
ASKER CERTIFIED SOLUTION
THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
ASKER
thank you very much all of you.
i found the problem was sheetnames where it was looking at b2 and my parameter sheet was in F column.
thanks so very much.
i found the problem was sheetnames where it was looking at b2 and my parameter sheet was in F column.
thanks so very much.
sheet list is correctly spelled. I have uploaded the file too.