Sub FindData()
'--purpose is to search multiple data sheets to find records
' that are exact match to user input parameters and
' near matches that are within specified variance.
'--assumptions about workbook setup:
' search data is in contiguous range starting at A1 on each data sheet
' each data sheet has headers and fields are same order as results header
Dim bIsValidRecord As Boolean, bWarned As Boolean
Dim adParams() As Double, adThisRecord() As Double
Dim lNdx As Long, lRow As Long, lNdxSheets As Long
Dim lMatchResultCount As Long, lNearResultCount As Long
Dim lParamCount As Long, lResultFieldsCount As Long
Dim rParams As Range, rResultHeaders As Range, rSaveActiveCell As Range
Dim avDataSheetNames() As Variant
Dim vData As Variant, vMatchResults As Variant, vNearResults As Variant
Dim wksData As Worksheet
'--maximum variance to be considered near match
Const dVARIANCE As Double = 1
'--limit of matches to be returned
Const lMAX_RESULTS As Long = 1000
'--column nbr of length field in data sheets
Const lSTART_PARAM_COL As Long = 2
'--identify data sheets to be searched
avDataSheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", _
"Sheet5", "Sheet6", "Sheet7")
'--find and validate worksheet ranges used for search
On Error Resume Next
Set rParams = Names("inpStockBoxSizeSearch").RefersToRange
Set rResultHeaders = Names("ptrStockBoxSizeSearchHeaders").RefersToRange
On Error GoTo ErrHandler
If rParams Is Nothing Or rResultHeaders Is Nothing Then
MsgBox "Named ranges for input cells or headers not found."
GoTo ExitProc
End If
If rParams.Rows.Count > 1 Or rResultHeaders.Rows.Count > 1 Then
MsgBox "Named ranges for input cells or headers reference more than one row"
GoTo ExitProc
End If
'--number of search parameters (length, width, depth)
lParamCount = rParams.Columns.Count
'--number of fields to be read for matching records
lResultFieldsCount = rResultHeaders.Columns.Count
'--clear previous search results
With rResultHeaders
.Parent.Rows(.Row + 1 & ":" & Rows.Count).ClearContents
End With
Set rSaveActiveCell = ActiveCell
'--read and validate search parameters
If Application.CountA(rParams) = lParamCount And _
Application.Count(rParams) = lParamCount Then
'--write params to array that used to compare to records
ReDim adParams(1 To lParamCount)
For lNdx = 1 To lParamCount
adParams(lNdx) = rParams(1, lNdx)
Next lNdx
'--sort descending-array is passed byRef
Call BubbleSortDoubles(adNumbers:=adParams)
Else
MsgBox "Enter numeric values for Length, Width and Depth"
GoTo ExitProc
End If
'--size array that will hold records meeting criteria
ReDim vMatchResults(1 To lMAX_RESULTS, 1 To lResultFieldsCount)
ReDim vNearResults(1 To lMAX_RESULTS, 1 To lResultFieldsCount)
ReDim adThisRecord(1 To lParamCount)
'--step through each data worksheet and find records that are matches
' or near matches to parameters
For lNdxSheets = LBound(avDataSheetNames) To UBound(avDataSheetNames)
On Error Resume Next
Set wksData = Nothing
Set wksData = Worksheets(avDataSheetNames(lNdxSheets))
On Error GoTo ErrHandler
If wksData Is Nothing Then
'--warn about missing sheet, but continue search
MsgBox "Sheet: " & avDataSheetNames(lNdxSheets) _
& " not found"
Else
vData = wksData.Range("A1").CurrentRegion.Value
If Not IsArray(vData) Then vData = Array(vData)
If UBound(vData, 2) < lParamCount Then
MsgBox "Not enough columns of data found in sheet: " _
& wksData.Name
Else
For lRow = 2 To UBound(vData, 1)
'--read each record's values to be compared vs parameters
' adThisRecord is passed byRef
bIsValidRecord = bReadRecord(adThisRecord, vData, lRow, _
lSTART_PARAM_COL)
If Not bIsValidRecord Then
If Not bWarned Then
MsgBox "Non-numeric data found in numeric field: " & vbCr _
& "Sheet: " & wksData.Name & vbCr _
& "Row: " & lRow
bWarned = True
End If
Else
'--sort descending-array is passed byRef
Call BubbleSortDoubles(adNumbers:=adThisRecord)
'--search for matches- add to arrays
If bIsMatch(dArr1:=adThisRecord, dArr2:=adParams) Then
'--write exact match to next record
If bAddResult(vResultArr:=vMatchResults, _
lNextNdx:=lMatchResultCount + 1, _
vData:=vData, lRow:=lRow) Then
lMatchResultCount = lMatchResultCount + 1
Else 'results exceed max
GoTo ExitProc
End If
ElseIf bIsNearMatch(dArr1:=adThisRecord, _
dArr2:=adParams, dMaxVariance:=dVARIANCE) Then
'--write near match to next record
If bAddResult(vResultArr:=vNearResults, _
lNextNdx:=lNearResultCount + 1, _
vData:=vData, lRow:=lRow) Then
lNearResultCount = lNearResultCount + 1
Else 'results exceed max
GoTo ExitProc
End If
End If
End If
Next lRow
End If 'enough fields
End If 'wksData exists
Next lNdxSheets
'--write results
If lMatchResultCount Then
rResultHeaders.Offset(1).Resize(lMatchResultCount, lResultFieldsCount) = vMatchResults
Else
MsgBox "No exact match meeting search parameters found"
End If
If lNearResultCount Then
rResultHeaders.Offset(1).Offset(IIf(lMatchResultCount, lMatchResultCount, 1)) _
.Resize(lNearResultCount, lResultFieldsCount) = vNearResults
End If
rSaveActiveCell.Select
ExitProc:
Application.CutCopyMode = False
Exit Sub
ErrHandler:
MsgBox Err.Number & "-" & Err.Description, vbExclamation, "Error"
Resume ExitProc
End Sub
Private Function bAddResult(ByRef vResultArr As Variant, ByVal lNextNdx As Long, _
ByVal vData As Variant, ByVal lRow As Long) As Boolean
Dim bReturn As Boolean
Dim lCol As Long
bReturn = True
If lNextNdx > UBound(vResultArr, 1) Then
MsgBox "Results found exceed maximum allowed"
bReturn = False
Else
For lCol = 1 To UBound(vResultArr, 2)
vResultArr(lNextNdx, lCol) = vData(lRow, lCol)
Next lCol
End If
bAddResult = bReturn
End Function
Private Function bIsMatch(ByRef dArr1() As Double, _
ByRef dArr2() As Double) As Boolean
'--compares corresponding elements of each array.
' returns True if all are equal, otherwise False.
'--assumes arrays have already been validated as vectors
' with same lbound and size
Dim bReturn As Boolean
Dim lNdx As Long
'--return true unless pair of non-matching elements found
bReturn = True
For lNdx = LBound(dArr1) To UBound(dArr1)
If dArr1(lNdx) <> dArr2(lNdx) Then
bReturn = False
Exit For
End If
Next lNdx
bIsMatch = bReturn
End Function
Private Function bIsNearMatch(ByRef dArr1() As Double, _
ByRef dArr2() As Double, ByVal dMaxVariance As Double) As Boolean
'--compares corresponding elements of each array.
' returns True if all are equal, otherwise False.
'--assumes arrays have already been validated as vectors
' with same lbound and size
Dim bReturn As Boolean
Dim lNdx As Long
'--return true unless pair of non-matching elements found
bReturn = True
For lNdx = LBound(dArr1) To UBound(dArr1)
If Abs(dArr1(lNdx) - dArr2(lNdx)) > dMaxVariance Then
bReturn = False
Exit For
End If
Next lNdx
bIsNearMatch = bReturn
End Function
Private Function bReadRecord(ByRef adThisRecord() As Double, _
ByVal vData As Variant, ByVal lRow As Long, _
ByVal lStartCol As Long) As Boolean
'--read indexed portion of record from 2D array vData
' validate that all items in record are numeric
' returns true if valid, else false
Dim bReturn As Boolean
Dim lNdx As Long
Dim vItem As Variant
bReturn = True
For lNdx = 1 To UBound(adThisRecord)
On Error Resume Next
vItem = vData(lRow, lStartCol + lNdx - 1)
If IsNumeric(vItem) Then
adThisRecord(lNdx) = CDbl(vItem)
Else
bReturn = False
Exit For
End If
Next lNdx
bReadRecord = bReturn
End Function
Private Sub BubbleSortDoubles(ByRef adNumbers() As Double)
'--bubble sort used for array with few elements
' items are sorted descending
Dim dTemp As Double
Dim i As Long, j As Long, lMax As Long
lMax = UBound(adNumbers)
For i = LBound(adNumbers) To lMax - 1
For j = i + 1 To lMax
If adNumbers(i) < adNumbers(j) Then
dTemp = adNumbers(i)
adNumbers(i) = adNumbers(j)
adNumbers(j) = dTemp
End If
Next j
Next i
End Sub
