Workbook search and display

J

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.
 
Sort by date Sort by votes
Do you want to clear table C before each search?
 
Upvote 0

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
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
 
Upvote 0
mumps said:
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
Click to expand...
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.
 
Upvote 0
Yes, just replace the existing code. The macro will recognize any additional sheets.
 
Upvote 0
JimLahey said:
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.
Click to expand...
mumps said:
Yes, just replace the existing code. The macro will recognize any additional sheets.
Click to expand...
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!
 
Upvote 0
JimLahey said:
I see you're reporting from Toronto area. Is that a drum set in your emoji avatar?
Click to expand...
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
 
Upvote 0
mumps said:
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
Click to expand...
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!
 
Upvote 0
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
 
Upvote 0
Solution
mumps said:
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
Click to expand...
This thing is solid!

Thank you mumps!!!

I look forward to your continued success.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Formula to move information to calendar
Replies
0
Views
61
jc352
J
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
252
Alex Blakenburg
A
D
  • Question
How do i get image1 control on userform to display a picture on a worksheet?
Replies
9
Views
422
DextNo1
D
J
  • Question
Formula to find date and return column number
Replies
2
Views
144
jc352
J
A
  • Question
Help with scanning barcodes into an excel invoice
2
Replies
12
Views
538
RoryA
RoryA

Forum statistics

Threads
1,214,387
Messages
6,119,208
Members
448,874
Latest member
Lancelots

Share this page

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
Back
Top