Workbook search and display

JimLahey

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I am looking how to accomplish: Search a same horizontal column on every sheet in workbook(same column (C2:C36) on each sheet) by entering keyword in a cell and display in a horizontal row (array) or series if multiple keywords are found display multiple horizontal rows (arrays)

Inventory workbook with: row (A1:AH) BIN, IMAGE, P/N, QTY., UoM, DESCRIPTION, PART TYPE

I am looking to search the P/N column for specific part number by entering a part number(string of numbers and or letters) and displaying a horizontal row of the information found in that row of worksheet AND if there are multiple P/N's found display those rows(table?) below in say, up to 10 items.

I am also wanting to do the same for the DESCRIPTION column with ability to use wild card search, such as: one or more keywords separated by "+" symbol and return row information that is found, if multiple descriptions are found, display those rows consecutively(table?) up to 10 items.

Any ideas where to start?

Thank you.
 

Some videos you may like

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

JimLahey

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
That would work, clearing after each search.

Thanks.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238
Try:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim PN As Range, ws As Worksheet, descr As Variant, i As Long, ii As Long, cnt As Long, splitD As Variant, sAddr As String
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Target <> "" Then
        Range("J9", Range("O" & Rows.Count).End(xlUp)).ClearContents
        Select Case Target.Row
            Case Is = 5
                For Each ws In Sheets
                    Set PN = ws.Range("C:C").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not PN Is Nothing Then
                        sAddr = PN.Address
                        Do
                            Cells(Rows.Count, "J").End(xlUp).Offset(1) = PN.Offset(, -2)
                            Cells(Rows.Count, "K").End(xlUp).Offset(1) = PN
                            Cells(Rows.Count, "L").End(xlUp).Offset(1) = PN.Offset(, 3)
                            Cells(Rows.Count, "M").End(xlUp).Offset(1) = PN.Offset(, 1)
                            Cells(Rows.Count, "N").End(xlUp).Offset(1) = PN.Offset(, 2)
                            Cells(Rows.Count, "O").End(xlUp).Offset(1) = PN.Offset(, 5)
                            Set PN = ws.Range("C:C").FindNext(PN)
                        Loop While PN.Address <> sAddr
                        sAddr = ""
                    End If
                Next ws
            Case Is = 6
                For Each ws In Sheets
                    descr = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp)).Resize(, 8).Value
                    For i = LBound(descr) To UBound(descr)
                        splitD = Split(Target, "+")
                        For ii = LBound(splitD) To UBound(splitD)
                            If InStr(descr(i, 6), splitD(ii)) Then
                                cnt = cnt + 1
                            End If
                        Next ii
                        If cnt = UBound(splitD) + 1 Then
                            Cells(Rows.Count, "J").End(xlUp).Offset(1) = descr(i, 1)
                            Cells(Rows.Count, "K").End(xlUp).Offset(1) = descr(i, 3)
                            Cells(Rows.Count, "L").End(xlUp).Offset(1) = descr(i, 6)
                            Cells(Rows.Count, "M").End(xlUp).Offset(1) = descr(i, 4)
                            Cells(Rows.Count, "N").End(xlUp).Offset(1) = descr(i, 5)
                            Cells(Rows.Count, "O").End(xlUp).Offset(1) = descr(i, 8)
                        End If
                        cnt = 0
                    Next i
                Next ws
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Select Case Target.Row
        Case Is = 5
            Target.Offset(1).ClearContents
        Case Is = 6
            Target.Offset(-1).ClearContents
    End Select
    Application.EnableEvents = True
End Sub
 

JimLahey

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Try:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim PN As Range, ws As Worksheet, descr As Variant, i As Long, ii As Long, cnt As Long, splitD As Variant, sAddr As String
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Target <> "" Then
        Range("J9", Range("O" & Rows.Count).End(xlUp)).ClearContents
        Select Case Target.Row
            Case Is = 5
                For Each ws In Sheets
                    Set PN = ws.Range("C:C").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not PN Is Nothing Then
                        sAddr = PN.Address
                        Do
                            Cells(Rows.Count, "J").End(xlUp).Offset(1) = PN.Offset(, -2)
                            Cells(Rows.Count, "K").End(xlUp).Offset(1) = PN
                            Cells(Rows.Count, "L").End(xlUp).Offset(1) = PN.Offset(, 3)
                            Cells(Rows.Count, "M").End(xlUp).Offset(1) = PN.Offset(, 1)
                            Cells(Rows.Count, "N").End(xlUp).Offset(1) = PN.Offset(, 2)
                            Cells(Rows.Count, "O").End(xlUp).Offset(1) = PN.Offset(, 5)
                            Set PN = ws.Range("C:C").FindNext(PN)
                        Loop While PN.Address <> sAddr
                        sAddr = ""
                    End If
                Next ws
            Case Is = 6
                For Each ws In Sheets
                    descr = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp)).Resize(, 8).Value
                    For i = LBound(descr) To UBound(descr)
                        splitD = Split(Target, "+")
                        For ii = LBound(splitD) To UBound(splitD)
                            If InStr(descr(i, 6), splitD(ii)) Then
                                cnt = cnt + 1
                            End If
                        Next ii
                        If cnt = UBound(splitD) + 1 Then
                            Cells(Rows.Count, "J").End(xlUp).Offset(1) = descr(i, 1)
                            Cells(Rows.Count, "K").End(xlUp).Offset(1) = descr(i, 3)
                            Cells(Rows.Count, "L").End(xlUp).Offset(1) = descr(i, 6)
                            Cells(Rows.Count, "M").End(xlUp).Offset(1) = descr(i, 4)
                            Cells(Rows.Count, "N").End(xlUp).Offset(1) = descr(i, 5)
                            Cells(Rows.Count, "O").End(xlUp).Offset(1) = descr(i, 8)
                        End If
                        cnt = 0
                    Next i
                Next ws
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Select Case Target.Row
        Case Is = 5
            Target.Offset(1).ClearContents
        Case Is = 6
            Target.Offset(-1).ClearContents
    End Select
    Application.EnableEvents = True
End Sub
I would copy and replace this over existing code?

What if I have future sheets? Does your code cover that?

Thanks. I'll try this out.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238

ADVERTISEMENT

Yes, just replace the existing code. The macro will recognize any additional sheets.
 

JimLahey

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
I would copy and replace this over existing code?

What if I have future sheets? Does your code cover that?

Thanks. I'll try this out.
Yes, just replace the existing code. The macro will recognize any additional sheets.
Thanks mumps!

I did some testing. The BIN locations are now populating in table C.

After a couple searches the text in table C headers:

LOOKUP BY
Part #
Description
BINPart #DescriptionQoHUoMPart Type
BB-GEO-DBbox, luminaire, exteriorea.electrical

start erasing and the table data starts either shifting up or down. The clearing of table between searches seems to clear cells and shifts table then starts populating searches on the bottom of existing data below table C.

22​
ea.
8​
ea.
LOOKUP BY
4​
ea.
Part #
5​
ea.
Descriptionbreaker+ 30 amp
1​
ea.
1​
ea.
2ea.
A-3-2Q02020Cbreaker, 20 amp, single pole, tandem
A-3-2Q01515Cbreaker, 15 amp, single pole, tandem
A-3-2Q0325breaker, 25 amp, 3 pole
A-4-1TEY115breaker, 15 amp, single pole, TEY
A-4-2TEY120breaker, 20 amp, single pole, TEY
A-2-58189box, metal 4" square
A-2-58189box, metal 4" square
A-1-3Q250CPbreaker, 50 amp, 2 pole
A-1-4Q250CP
23​
A-1-1Q120CPbreaker, 20 amp, single pole
A-1-2Q230CPbreaker, 30 amp, 2 pole
A-1-3Q250CPbreaker, 50 amp, 2 pole
A-2-1Q0220CPbreaker, 20 amp, 2 pole
A-2-2Q0B330breaker, 30 amp, 3 pole
A-2-2Q0330CPbreaker, 30 amp, 3 pole
A-2-3Q0B350breaker, 50 amp, 3 pole
A-2-3Q0350VHbreaker, 50 amp, 3 pole
A-3-1Q0320CPbreaker, 20 amp, 3 pole
A-3-1Q0B320breaker, 20 amp, 3 pole
A-3-2Q02020Cbreaker, 20 amp, single pole, tandem
A-3-2Q01515Cbreaker, 15 amp, single pole, tandem
A-3-2Q0325breaker, 25 amp, 3 pole
A-4-1TEY115breaker, 15 amp, single pole, TEY
A-4-2TEY120breaker, 20 amp, single pole, TEY
A-1-2Q230CPbreaker, 30 amp, 2 pole
A-2-2Q0B330breaker, 30 amp, 3 pole
A-2-2Q0330CPbreaker, 30 amp, 3 pole

If you get a chance to play around with search function with updated code, that would be a big help. Maybe that would be a better representation of what's happening.

It seems to be happening after 3rd search.

Thanks.

I see you're reporting from Toronto area. Is that a drum set in your emoji avatar?

Cheers!
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238

ADVERTISEMENT

I see you're reporting from Toronto area. Is that a drum set in your emoji avatar?
Yes, that is a drum set. The image got distorted when this site changed its user interface so it's not too clear. I was a drummer in my earlier years.
Some of the blank cells were causing a problem. Try this revised code:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim PN As Range, ws As Worksheet, descr As Variant, i As Long, ii As Long, cnt As Long, splitD As Variant, sAddr As String, x As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Target <> "" Then
        Range("J9", Range("J" & Rows.Count).End(xlUp)).Resize(, 6).ClearContents
        Select Case Target.Row
            Case Is = 5
                For Each ws In Sheets
                    Set PN = ws.Range("C:C").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not PN Is Nothing Then
                        sAddr = PN.Address
                        x = 9
                        Do
                            Range("J" & x) = PN.Offset(, -2)
                            Range("K" & x) = PN
                            Range("L" & x) = PN.Offset(, 3)
                            Range("M" & x) = PN.Offset(, 1)
                            Range("N" & x) = PN.Offset(, 2)
                            Range("O" & x) = PN.Offset(, 5)
                            Set PN = ws.Range("C:C").FindNext(PN)
                            x = x + 1
                        Loop While PN.Address <> sAddr
                        sAddr = ""
                    End If
                Next ws
            Case Is = 6
                x = 9
                For Each ws In Sheets
                    descr = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp)).Resize(, 8).Value
                    For i = LBound(descr) To UBound(descr)
                        splitD = Split(Target, "+")
                        For ii = LBound(splitD) To UBound(splitD)
                            If InStr(descr(i, 6), splitD(ii)) Then
                                cnt = cnt + 1
                            End If
                        Next ii
                        If cnt = UBound(splitD) + 1 Then
                            Range("J" & x) = descr(i, 1)
                            Range("K" & x) = descr(i, 3)
                            Range("L" & x) = descr(i, 6)
                            Range("M" & x) = descr(i, 4)
                            Range("N" & x) = descr(i, 5)
                            Range("O" & x) = descr(i, 8)
                            x = x + 1
                        End If
                        cnt = 0
                    Next i
                Next ws
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Select Case Target.Row
        Case Is = 5
            Target.Offset(1).ClearContents
        Case Is = 6
            Target.Offset(-1).ClearContents
    End Select
    Application.EnableEvents = True
End Sub
 

JimLahey

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Yes, that is a drum set. The image got distorted when this site changed its user interface so it's not too clear. I was a drummer in my earlier years.
Some of the blank cells were causing a problem. Try this revised code:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim PN As Range, ws As Worksheet, descr As Variant, i As Long, ii As Long, cnt As Long, splitD As Variant, sAddr As String, x As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Target <> "" Then
        Range("J9", Range("J" & Rows.Count).End(xlUp)).Resize(, 6).ClearContents
        Select Case Target.Row
            Case Is = 5
                For Each ws In Sheets
                    Set PN = ws.Range("C:C").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not PN Is Nothing Then
                        sAddr = PN.Address
                        x = 9
                        Do
                            Range("J" & x) = PN.Offset(, -2)
                            Range("K" & x) = PN
                            Range("L" & x) = PN.Offset(, 3)
                            Range("M" & x) = PN.Offset(, 1)
                            Range("N" & x) = PN.Offset(, 2)
                            Range("O" & x) = PN.Offset(, 5)
                            Set PN = ws.Range("C:C").FindNext(PN)
                            x = x + 1
                        Loop While PN.Address <> sAddr
                        sAddr = ""
                    End If
                Next ws
            Case Is = 6
                x = 9
                For Each ws In Sheets
                    descr = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp)).Resize(, 8).Value
                    For i = LBound(descr) To UBound(descr)
                        splitD = Split(Target, "+")
                        For ii = LBound(splitD) To UBound(splitD)
                            If InStr(descr(i, 6), splitD(ii)) Then
                                cnt = cnt + 1
                            End If
                        Next ii
                        If cnt = UBound(splitD) + 1 Then
                            Range("J" & x) = descr(i, 1)
                            Range("K" & x) = descr(i, 3)
                            Range("L" & x) = descr(i, 6)
                            Range("M" & x) = descr(i, 4)
                            Range("N" & x) = descr(i, 5)
                            Range("O" & x) = descr(i, 8)
                            x = x + 1
                        End If
                        cnt = 0
                    Next i
                Next ws
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Select Case Target.Row
        Case Is = 5
            Target.Offset(1).ClearContents
        Case Is = 6
            Target.Offset(-1).ClearContents
    End Select
    Application.EnableEvents = True
End Sub
I tried doing a part search for item "Q250CP" in BIN A-1-(3-4). The headings J8:O8, keep disappearing. Maybe ( "key in either p/n or description" -> "enter" -> "display results if any", "key in new either search" -> "enter" -> "clear table J9:O19" -> "display results if any" ) , repeat.

Thanks for continued support mumps. You've been a really big help!
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238
Delete the Worksheet_SelectionChange macro in your file and try just the one macro below.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim PN As Range, ws As Worksheet, descr As Variant, i As Long, ii As Long, cnt As Long, splitD As Variant, sAddr As String, x As Long
    Dim lRow As Long
    lRow = Range("J" & Rows.Count).End(xlUp).Row
    If lRow < 9 Then lRow = 9
    If Target <> "" Then
        Range("J9:J" & lRow).Resize(, 6).ClearContents
        Select Case Target.Row
            Case Is = 5
                For Each ws In Sheets
                    Set PN = ws.Range("C:C").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not PN Is Nothing Then
                        sAddr = PN.Address
                        x = 9
                        Do
                            Range("J" & x) = PN.Offset(, -2)
                            Range("K" & x) = PN
                            Range("L" & x) = PN.Offset(, 3)
                            Range("M" & x) = PN.Offset(, 1)
                            Range("N" & x) = PN.Offset(, 2)
                            Range("O" & x) = PN.Offset(, 5)
                            Set PN = ws.Range("C:C").FindNext(PN)
                            x = x + 1
                        Loop While PN.Address <> sAddr
                        sAddr = ""
                    End If
                Next ws
                Target.ClearContents
                Target.Offset(1).ClearContents
            Case Is = 6
                x = 9
                For Each ws In Sheets
                    descr = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp)).Resize(, 8).Value
                    For i = LBound(descr) To UBound(descr)
                        splitD = Split(Target, "+")
                        For ii = LBound(splitD) To UBound(splitD)
                            If InStr(descr(i, 6), splitD(ii)) Then
                                cnt = cnt + 1
                            End If
                        Next ii
                        If cnt = UBound(splitD) + 1 Then
                            Range("J" & x) = descr(i, 1)
                            Range("K" & x) = descr(i, 3)
                            Range("L" & x) = descr(i, 6)
                            Range("M" & x) = descr(i, 4)
                            Range("N" & x) = descr(i, 5)
                            Range("O" & x) = descr(i, 8)
                            x = x + 1
                        End If
                        cnt = 0
                    Next i
                Next ws
                Target.ClearContents
                Target.Offset(-1).ClearContents
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Solution

JimLahey

New Member
Joined
Dec 31, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Delete the Worksheet_SelectionChange macro in your file and try just the one macro below.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("L5:L6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim PN As Range, ws As Worksheet, descr As Variant, i As Long, ii As Long, cnt As Long, splitD As Variant, sAddr As String, x As Long
    Dim lRow As Long
    lRow = Range("J" & Rows.Count).End(xlUp).Row
    If lRow < 9 Then lRow = 9
    If Target <> "" Then
        Range("J9:J" & lRow).Resize(, 6).ClearContents
        Select Case Target.Row
            Case Is = 5
                For Each ws In Sheets
                    Set PN = ws.Range("C:C").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not PN Is Nothing Then
                        sAddr = PN.Address
                        x = 9
                        Do
                            Range("J" & x) = PN.Offset(, -2)
                            Range("K" & x) = PN
                            Range("L" & x) = PN.Offset(, 3)
                            Range("M" & x) = PN.Offset(, 1)
                            Range("N" & x) = PN.Offset(, 2)
                            Range("O" & x) = PN.Offset(, 5)
                            Set PN = ws.Range("C:C").FindNext(PN)
                            x = x + 1
                        Loop While PN.Address <> sAddr
                        sAddr = ""
                    End If
                Next ws
                Target.ClearContents
                Target.Offset(1).ClearContents
            Case Is = 6
                x = 9
                For Each ws In Sheets
                    descr = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp)).Resize(, 8).Value
                    For i = LBound(descr) To UBound(descr)
                        splitD = Split(Target, "+")
                        For ii = LBound(splitD) To UBound(splitD)
                            If InStr(descr(i, 6), splitD(ii)) Then
                                cnt = cnt + 1
                            End If
                        Next ii
                        If cnt = UBound(splitD) + 1 Then
                            Range("J" & x) = descr(i, 1)
                            Range("K" & x) = descr(i, 3)
                            Range("L" & x) = descr(i, 6)
                            Range("M" & x) = descr(i, 4)
                            Range("N" & x) = descr(i, 5)
                            Range("O" & x) = descr(i, 8)
                            x = x + 1
                        End If
                        cnt = 0
                    Next i
                Next ws
                Target.ClearContents
                Target.Offset(-1).ClearContents
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
This thing is solid!

Thank you mumps!!!

I look forward to your continued success.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,387
Messages
5,624,389
Members
416,026
Latest member
melvic69

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top