Sub FindData()
'--searches multiple data sheets to find records
' that are exact match to user input parameters or
' near matches that are within specified variance.
Dim adParams() As Double, adThisRecord() As Double
Dim lNdx As Long, lRow As Long, lCol As Long
Dim lMatchResultCount As Long, lNearResultCount As Long
Dim lTotalResultCount As Long
Dim rParams As Range, rSaveActiveCell As Range
Dim vData As Variant, vMatchResults As Variant, vNearResults As Variant
Dim wksData As Worksheet, wksResults As Worksheet
'--maximum variance to be considered near match
Const dVARIANCE As Double = 1
'--number of search parameters (length, width, depth)
Const lPARAM_COUNT As Long = 3
'--number of fields to be read for matching records
' 1=StockNbr; 2=DesignNbr; 3=Length; 4=Width; 5=Depth; 6=Flute
Const lRESULT_FIELDS_COUNT As Long = 6
'--column nbr of length field in data sheets
Const lFIRST_PARAM_COL As Long = 3
'--limit of matches to be returned
Const lMAX_RESULTS As Long = 1000
'--location of range with search parameters
Set wksResults = Sheets("Stock box Lookup")
Set rParams = wksResults.Range("H4").Resize(1, lPARAM_COUNT)
'--clear previous search results
With wksResults
.Rows("5:" & Rows.Count).ClearContents
.Range("F4:G4,K4").ClearContents
End With
Set rSaveActiveCell = ActiveCell
'--read and validate search parameters
If Application.CountA(rParams) = lPARAM_COUNT And _
Application.Count(rParams) = lPARAM_COUNT Then
'--write params to array that used to compare to records
ReDim adParams(1 To lPARAM_COUNT)
For lNdx = 1 To lPARAM_COUNT
adParams(lNdx) = rParams(1, lNdx)
Next lNdx
Else
MsgBox "Enter numeric values for Length, Width and Depth"
GoTo ExitProc
End If
'--size arrays that will hold records meeting criteria
ReDim vMatchResults(1 To lMAX_RESULTS, 1 To lRESULT_FIELDS_COUNT)
ReDim vNearResults(1 To lMAX_RESULTS, 1 To lRESULT_FIELDS_COUNT)
ReDim adThisRecord(1 To lPARAM_COUNT)
'--step through each data worksheet and find records that are matches
' or near matches to parameters
For Each wksData In ActiveWorkbook.Worksheets(Array( _
"Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7"))
vData = wksData.Range("A1").CurrentRegion.Value
For lRow = 1 To UBound(vData, 1)
'--read each record's values to be compared vs parameters
For lNdx = 1 To lPARAM_COUNT
On Error Resume Next
adThisRecord(lNdx) = vData(lRow, lFIRST_PARAM_COL + lNdx - 1)
If Err.Number <> 0 Then
Err.Clear
MsgBox "Non-numeric data found in numeric field: " & vbCr _
& "Sheet: " & wksData.Name & vbCr _
& "Row: " & lRow
Resume Next
End If
On Error GoTo 0
Next lNdx
If bIsMatch(dArr1:=adThisRecord, dArr2:=adParams) Then
'--write exact match to next record
lMatchResultCount = lMatchResultCount + 1
If lMatchResultCount > lMAX_RESULTS Then
MsgBox "Matches found exceed maximum allowed"
GoTo ExitProc
End If
For lCol = 1 To lRESULT_FIELDS_COUNT
vMatchResults(lMatchResultCount, lCol) = vData(lRow, lCol)
Next lCol
ElseIf bIsNearMatch(dArr1:=adThisRecord, dArr2:=adParams, _
dMaxVariance:=dVARIANCE) Then
'--write near match to next record
lNearResultCount = lNearResultCount + 1
If lNearResultCount > lMAX_RESULTS Then
MsgBox "Near matches found exceed maximum allowed"
GoTo ExitProc
End If
For lCol = 1 To lRESULT_FIELDS_COUNT
vNearResults(lNearResultCount, lCol) = vData(lRow, lCol)
Next lCol
End If
Next lRow
Next wksData
'--write results
If lMatchResultCount Then
wksResults.Range("F4").Resize(lMatchResultCount, lRESULT_FIELDS_COUNT) = vMatchResults
Else
MsgBox "No exact match meeting search parameters found"
End If
If lNearResultCount Then
wksResults.Range("F4").Offset(IIf(lMatchResultCount, lMatchResultCount, 1)) _
.Resize(lNearResultCount, lRESULT_FIELDS_COUNT) = vNearResults
End If
lTotalResultCount = lMatchResultCount + lNearResultCount
If lTotalResultCount > 1 Then
'--copy down formulas for result rows
With wksResults.Range("A4:E4")
.Copy
.Resize(lTotalResultCount).PasteSpecial (xlPasteFormulas)
End With
End If
rSaveActiveCell.Select
ExitProc:
Application.CutCopyMode = False
End Sub
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 none have more than the specified variance, 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
