Option Explicit
‘====================================================================
‘ DEEP SEARCH INVENTORY MACRO (ANY-COLUMN VERSION)
‘
‘ Search Input:
‘ Sheet: “search input”
‘ Search terms: A2, A3, A4…
‘
‘ Inventory:
‘ Sheet: “inventory”
‘ Row 1 = headers
‘ ALL columns (1 .. last used column) are searched
‘
‘ Result:
‘ Sheet: “deep search result”
‘ A = Search Input
‘ B/C = blank
‘ D onward = inventory data
‘
‘ FEATURES
‘ 1. Case-insensitive matching
‘ 2. Ignores – / space _ . ( )
‘ 3. Matches search term against EVERY column in the row
‘ 4. Minimum match length = 3
‘ 5. Partial matching in both directions
‘ 6. Matching text highlighted red (in whichever column matched)
‘ 7. No background colors
‘ 8. All matching rows for one search term are grouped together
‘ 9. Column A vertically merged for multiple rows
‘ 10. Duplicate search terms use cached results
‘ 11. No .Select operation
‘ 12. No merge warning
‘====================================================================
Private Const SHEET_INVENTORY As String = “inventory”
Private Const SHEET_SEARCHINPUT As String = “search input”
Private Const SHEET_RESULT As String = “deep search result”
Private Const RESULT_FIRST_DATA_COL As Long = 4 ‘ D
Private Const MIN_MATCH_LEN As Long = 3
‘ Characters ignored during normalization
Private Const SEP_CHARS As String = “-/ _.()”
‘====================================================================
‘ MAIN ENTRY POINT
‘====================================================================
Sub DeepSearchInventory()
Dim wsInv As Worksheet
Dim wsIn As Worksheet
Dim wsRes As Worksheet
Dim origScreenUpdating As Boolean
Dim origEnableEvents As Boolean
Dim origCalc As XlCalculation
On Error GoTo ErrHandler
‘————————————————————
‘ Get worksheets
‘————————————————————
Set wsInv = ThisWorkbook.Sheets(SHEET_INVENTORY)
Set wsIn = ThisWorkbook.Sheets(SHEET_SEARCHINPUT)
‘————————————————————
‘ Save Excel settings
‘————————————————————
origScreenUpdating = Application.ScreenUpdating
origEnableEvents = Application.EnableEvents
origCalc = Application.Calculation
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
‘————————————————————
‘ Read search inputs
‘————————————————————
Dim searchTerms() As String
Dim nTerms As Long
nTerms = ReadSearchInputs(wsIn, searchTerms)
If nTerms = 0 Then
MsgBox “No search terms found in ‘” & _
SHEET_SEARCHINPUT & “‘!A2:A…”, _
vbExclamation
GoTo CleanExit
End If
‘————————————————————
‘ Load inventory into memory
‘————————————————————
Dim invData As Variant
Dim lastInvRow As Long
Dim lastInvCol As Long
GetInventoryData _
wsInv, _
invData, _
lastInvRow, _
lastInvCol
If lastInvRow < 2 Then
MsgBox “No data rows found on ‘” & _
SHEET_INVENTORY & “‘.”, _
vbExclamation
GoTo CleanExit
End If
‘————————————————————
‘ Pre-normalize EVERY inventory column
‘————————————————————
Dim normAll() As String ‘ normAll(row, col)
Dim mapAll() As Variant ‘ mapAll(row, col) -> Long() position map
PrecomputeNormalization _
invData, _
lastInvRow, _
lastInvCol, _
normAll, _
mapAll
‘————————————————————
‘ Prepare result sheet
‘————————————————————
Set wsRes = PrepareResultSheet()
‘————————————————————
‘ Write header
‘————————————————————
WriteResultHeader _
wsRes, _
wsInv, _
lastInvCol
‘————————————————————
‘ Cache
‘————————————————————
Dim cache As Object
Set cache = CreateObject(“Scripting.Dictionary”)
‘————————————————————
‘ Process search terms
‘————————————————————
Dim outRow As Long
Dim i As Long
outRow = 2
For i = 1 To nTerms
outRow = ProcessSearchTerm( _
searchTerms(i), _
wsRes, _
outRow, _
invData, _
lastInvRow, _
lastInvCol, _
normAll, _
mapAll, _
cache)
Next i
‘————————————————————
‘ Format result sheet
‘————————————————————
With wsRes
.Columns.AutoFit
‘ No background colour
.Cells.Interior.Pattern = xlNone
‘ Header
.Rows(1).Font.Bold = True
End With
‘————————————————————
‘ Finished
‘————————————————————
MsgBox “Deep Search complete. ” & _
nTerms & ” search term(s) processed.”, _
vbInformation
CleanExit:
Application.ScreenUpdating = origScreenUpdating
Application.EnableEvents = origEnableEvents
Application.Calculation = origCalc
Exit Sub
ErrHandler:
MsgBox “Deep Search failed!” & vbCrLf & _
“Error ” & Err.Number & “: ” & Err.Description, _
vbCritical
Resume CleanExit
End Sub
‘====================================================================
‘ READ SEARCH INPUTS
‘====================================================================
Private Function ReadSearchInputs( _
ws As Worksheet, _
ByRef terms() As String) As Long
Dim lastRow As Long
Dim r As Long
Dim n As Long
Dim s As String
lastRow = ws.Cells( _
ws.Rows.Count, _
“A”).End(xlUp).Row
If lastRow < 2 Then
ReDim terms(1 To 1)
ReadSearchInputs = 0
Exit Function
End If
ReDim terms(1 To lastRow – 1)
n = 0
For r = 2 To lastRow
If Not IsEmpty(ws.Cells(r, 1).Value) Then
s = Trim$(CStr(ws.Cells(r, 1).Value))
If Len(s) > 0 Then
n = n + 1
terms(n) = s
End If
End If
Next r
If n > 0 Then
ReDim Preserve terms(1 To n)
End If
ReadSearchInputs = n
End Function
‘====================================================================
‘ LOAD INVENTORY DATA INTO MEMORY
‘====================================================================
Private Sub GetInventoryData( _
ws As Worksheet, _
ByRef data As Variant, _
ByRef lastRow As Long, _
ByRef lastCol As Long)
Dim ur As Range
Set ur = ws.UsedRange
lastRow = ur.Rows(ur.Rows.Count).Row
lastCol = ur.Columns(ur.Columns.Count).Column
If lastRow < 1 Then
lastRow = 1
End If
data = ws.Range( _
ws.Cells(1, 1), _
ws.Cells(lastRow, lastCol) _
).Value2
End Sub
‘====================================================================
‘ SAFE CELL TEXT
‘====================================================================
Private Function CellText( _
data As Variant, _
r As Long, _
c As Long) As String
On Error GoTo NoValue
Dim v As Variant
If c > UBound(data, 2) Then
GoTo NoValue
End If
v = data(r, c)
If IsError(v) Then
GoTo NoValue
End If
If IsEmpty(v) Then
GoTo NoValue
End If
CellText = CStr(v)
Exit Function
NoValue:
CellText = “”
End Function
‘====================================================================
‘ NORMALIZE TEXT + POSITION MAP
‘
‘ Removes: – / space _ . ( )
‘ Converts to uppercase.
‘
‘ Example: 1756-L61 becomes 1756L61
‘====================================================================
Private Function NormalizeWithMap( _
ByVal s As String, _
ByRef mapArr() As Long) As String
Dim i As Long
Dim ch As String
Dim cnt As Long
Dim nStr As String
Dim tmpMap() As Long
If Len(s) = 0 Then
ReDim mapArr(1 To 1)
NormalizeWithMap = “”
Exit Function
End If
ReDim tmpMap(1 To Len(s))
nStr = “”
cnt = 0
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If InStr(SEP_CHARS, ch) = 0 Then
cnt = cnt + 1
nStr = nStr & UCase$(ch)
tmpMap(cnt) = i
End If
Next i
If cnt = 0 Then
ReDim mapArr(1 To 1)
NormalizeWithMap = “”
Else
ReDim mapArr(1 To cnt)
For i = 1 To cnt
mapArr(i) = tmpMap(i)
Next i
NormalizeWithMap = nStr
End If
End Function
‘====================================================================
‘ PRECOMPUTE NORMALIZATION FOR EVERY COLUMN
‘====================================================================
Private Sub PrecomputeNormalization( _
invData As Variant, _
lastRow As Long, _
lastCol As Long, _
ByRef normAll() As String, _
ByRef mapAll() As Variant)
ReDim normAll(1 To lastRow, 1 To lastCol)
ReDim mapAll(1 To lastRow, 1 To lastCol)
Dim r As Long
Dim c As Long
Dim txt As String
Dim m() As Long
For r = 2 To lastRow
For c = 1 To lastCol
txt = CellText( _
invData, _
r, _
c)
normAll(r, c) = NormalizeWithMap(txt, m)
mapAll(r, c) = m
Next c
Next r
End Sub
‘====================================================================
‘ FIND MATCH SPAN
‘====================================================================
Private Function FindMatchSpan( _
normCell As String, _
normSearch As String, _
minLen As Long, _
ByRef spanStart As Long, _
ByRef spanLen As Long) As Boolean
spanStart = 0
spanLen = 0
FindMatchSpan = False
If Len(normCell) = 0 Then Exit Function
If Len(normSearch) = 0 Then Exit Function
Dim p As Long
‘————————————————————
‘ Search term is shorter/equal
‘————————————————————
If Len(normSearch) <= Len(normCell) Then
If Len(normSearch) < minLen Then
Exit Function
End If
p = InStr( _
1, _
normCell, _
normSearch, _
vbBinaryCompare)
If p > 0 Then
spanStart = p
spanLen = Len(normSearch)
FindMatchSpan = True
End If
‘————————————————————
‘ Inventory value is shorter
‘————————————————————
Else
If Len(normCell) < minLen Then
Exit Function
End If
p = InStr( _
1, _
normSearch, _
normCell, _
vbBinaryCompare)
If p > 0 Then
spanStart = 1
spanLen = Len(normCell)
FindMatchSpan = True
End If
End If
End Function
‘====================================================================
‘ PREPARE RESULT SHEET
‘====================================================================
Private Function PrepareResultSheet() As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SHEET_RESULT)
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add( _
After:=ThisWorkbook.Sheets( _
ThisWorkbook.Sheets.Count))
ws.Name = SHEET_RESULT
Else
On Error Resume Next
ws.Cells.UnMerge
On Error GoTo 0
ws.Cells.Clear
End If
ws.Cells.Interior.Pattern = xlNone
Set PrepareResultSheet = ws
End Function
‘====================================================================
‘ WRITE RESULT HEADER
‘====================================================================
Private Sub WriteResultHeader( _
wsRes As Worksheet, _
wsInv As Worksheet, _
lastInvCol As Long)
wsRes.Cells(1, 1).Value = “Search Input”
‘ B & C intentionally blank
Dim c As Long
For c = 1 To lastInvCol
wsRes.Cells( _
1, _
RESULT_FIRST_DATA_COL + c – 1 _
).Value = wsInv.Cells(1, c).Value
Next c
wsRes.Rows(1).Font.Bold = True
End Sub
‘====================================================================
‘ COMPUTE MATCHES
‘
‘ Every inventory row is checked against EVERY column.
‘ A row is returned only once even if multiple columns match,
‘ but ALL matching columns are remembered so they can all be
‘ highlighted later.
‘====================================================================
Private Function ComputeMatches( _
normSearch As String, _
lastRow As Long, _
lastCol As Long, _
normAll() As String) As Collection
Dim results As New Collection
Dim r As Long
Dim c As Long
Dim sSpan As Long
Dim lSpan As Long
Dim rowMatches As Collection
For r = 2 To lastRow
Set rowMatches = New Collection
For c = 1 To lastCol
If FindMatchSpan( _
normAll(r, c), _
normSearch, _
MIN_MATCH_LEN, _
sSpan, _
lSpan) Then
Dim hit(0 To 2) As Long
hit(0) = c
hit(1) = sSpan
hit(2) = lSpan
rowMatches.Add hit
End If
Next c
If rowMatches.Count > 0 Then
Dim rec(0 To 1) As Variant
rec(0) = r
Set rec(1) = rowMatches
results.Add rec
End If
Next r
Set ComputeMatches = results
End Function
‘====================================================================
‘ PROCESS ONE SEARCH TERM
‘
‘ IMPORTANT:
‘ Column A contains the search term ONLY in the first result row.
‘ Other cells in the merge range are EMPTY before .Merge.
‘ Therefore Excel does NOT display the merge warning.
‘====================================================================
Private Function ProcessSearchTerm( _
term As String, _
wsRes As Worksheet, _
startRow As Long, _
invData As Variant, _
lastInvRow As Long, _
lastInvCol As Long, _
normAll() As String, _
mapAll() As Variant, _
cache As Object) As Long
Dim dummyMap() As Long
Dim normS As String
normS = NormalizeWithMap( _
term, _
dummyMap)
‘————————————————————
‘ Get cached results or calculate them
‘————————————————————
Dim results As Collection
If cache.Exists(normS) Then
Set results = cache(normS)
Else
Set results = ComputeMatches( _
normS, _
lastInvRow, _
lastInvCol, _
normAll)
cache.Add normS, results
End If
Dim outRow As Long
outRow = startRow
‘————————————————————
‘ No matches
‘————————————————————
If results.Count = 0 Then
wsRes.Cells(outRow, 1).Value = term
wsRes.Cells( _
outRow, _
RESULT_FIRST_DATA_COL _
).Value = “No match found”
ProcessSearchTerm = outRow + 1
Exit Function
End If
‘————————————————————
‘ Write all matching inventory rows together
‘————————————————————
Dim rec As Variant
Dim invRow As Long
Dim c As Long
Dim rowArr() As Variant
For Each rec In results
invRow = rec(0)
Dim rowMatches As Collection
Set rowMatches = rec(1)
‘——————————————————–
‘ Only FIRST result row gets the search term in col A.
‘——————————————————–
If outRow = startRow Then
wsRes.Cells( _
outRow, _
1).Value = term
Else
wsRes.Cells( _
outRow, _
1).ClearContents
End If
‘——————————————————–
‘ Copy inventory data starting at Column D
‘——————————————————–
ReDim rowArr( _
1 To 1, _
1 To lastInvCol)
For c = 1 To lastInvCol
rowArr(1, c) = invData(invRow, c)
Next c
wsRes.Range( _
wsRes.Cells( _
outRow, _
RESULT_FIRST_DATA_COL), _
wsRes.Cells( _
outRow, _
RESULT_FIRST_DATA_COL + lastInvCol – 1) _
).Value = rowArr
‘——————————————————–
‘ Highlight EVERY matching column for this row
‘——————————————————–
Dim hit As Variant
For Each hit In rowMatches
HighlightIfMatch _
wsRes, _
outRow, _
RESULT_FIRST_DATA_COL + hit(0) – 1, _
CLng(hit(1)), _
CLng(hit(2)), _
mapAll(invRow, hit(0))
Next hit
outRow = outRow + 1
Next rec
‘————————————————————
‘ MERGE COLUMN A
‘————————————————————
If outRow – startRow > 1 Then
Dim mergeRange As Range
Set mergeRange = wsRes.Range( _
wsRes.Cells(startRow, 1), _
wsRes.Cells(outRow – 1, 1))
If mergeRange.Rows.Count > 1 Then
mergeRange.Offset(1, 0) _
.Resize(mergeRange.Rows.Count – 1, 1) _
.ClearContents
End If
mergeRange.Cells(1, 1).Value = term
mergeRange.Merge
mergeRange.VerticalAlignment = xlCenter
mergeRange.HorizontalAlignment = xlCenter
End If
ProcessSearchTerm = outRow
End Function
‘====================================================================
‘ HIGHLIGHT MATCHED TEXT IN RED
‘
‘ Converts normalized positions back to original cell positions.
‘====================================================================
Private Sub HighlightIfMatch( _
ws As Worksheet, _
r As Long, _
c As Long, _
spanStart As Long, _
spanLen As Long, _
mapArr As Variant)
If spanStart = 0 Then Exit Sub
If spanLen = 0 Then Exit Sub
Dim origStart As Long
Dim origEnd As Long
On Error GoTo SafeExit
origStart = mapArr(spanStart)
origEnd = mapArr( _
spanStart + spanLen – 1)
Dim cel As Range
Set cel = ws.Cells(r, c)
If Len(CStr(cel.Value)) = 0 Then Exit Sub
cel.Characters( _
origStart, _
origEnd – origStart + 1 _
).Font.Color = vbRed
SafeExit:
End Sub
