Search One Column in Mulitple Sheets

J

joseph00

New Member
Joined
Oct 1, 2011
Messages
5
So I have a Timesheet excel spreadsheet where each sheet name is a different employee name. Each sheet is where employee's start and end time gets logged as well as date, procedure code, hrs worked etc.

In column "O" next to the start and end time is the client they worked for.

I want to have a summary sheet where each client is listed and the values in columns A:N on the same row the client name was found.

This code seemed like it could work if I entered in every employee name next to "Searchsheets" and every client name next to "Vendor"

http://www.mrexcel.com/forum/showthread.php?p=2814856#post2814856
(It's the last posted code in this thread)

I'm very new to VBA and am using excel 2010. The add-in "SearchWord" does something similar to what I'm looking for when I change the columns searched from "B" to "O" but I can't get any other data to display on a summary page. http://www.vbaexpress.com/kb/getarticle.php?kb_id=780

Any help would be greatly appreciated.
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
Ok so I figured out how to get all the necessary offset columns I need. Here's my updated code so far:

Code: 
 'In the SearchWord sheet
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$B$1" Then
        Application.Run "SearchWord.xla!FindAll", Target.Text, "False"
        Cells(1, 2).Select
    End If
End Sub
 
 'In ThisWorkbook of the Add-In
Option Explicit
Private Sub Workbook_AddinInstall()
    On Error Resume Next
    Application.CommandBars("Tools").Controls("Search &word").Delete
    On Error GoTo 0
    With Application.CommandBars("Tools").Controls.Add
        .Caption = "Search &word"
        .Tag = "Search word"
        .OnAction = "'" & ThisWorkbook.Name & "'!Search.DoFindAll"
    End With
    MsgBox "'Search word' option added to Tools menu"
End Sub
 
Private Sub Workbook_AddinUninstall()
    On Error Resume Next
    Application.CommandBars("Tools").Controls("Search &word").Delete
End Sub
 
 'In a module of the Add-In
Option Compare Text
Option Explicit
 
Public Sub DoFindAll()
    FindAll "", "True"
End Sub
 
Public Sub FindAll(Search As String, Reset As Boolean)
     
    Dim WB              As Workbook
    Dim WS              As Worksheet
    Dim Cell            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim FindCell()      As String
    Dim FindSheet()     As String
    Dim FindWorkBook()  As String
    Dim FindPath()      As String
    Dim FindText()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim Path            As String
     
    If Search = "" Then
        Prompt = "What do you want to search for in the worbook: " & _
        vbNewLine & vbNewLine & Path
        Title = "Search Criteria Input"
        Search = InputBox(Prompt, Title, "Enter search term")
        If Search = "" Then
            GoTo Cancelled
        End If
    End If
     
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    On Error GoTo Cancelled
     
    Set WB = ActiveWorkbook
    For Each WS In WB.Worksheets
        If WS.Name <> "SearchWord" Then
             'Search whole sheet
             'With WB.Sheets(WS.Name).Cells
             '***********************************
             'Alternative to search single column
            With WB.Sheets(WS.Name).Range("O:O")
                 '***********************************
                Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
                MatchCase:=False, SearchOrder:=xlByColumns)
                If Not Cell Is Nothing Then
                    FirstAddress = Cell.Address
                    Do
                        Counter = Counter + 1
                        ReDim Preserve FindCell(1 To Counter)
                        ReDim Preserve FindSheet(1 To Counter)
                        ReDim Preserve FindWorkBook(1 To Counter)
                        ReDim Preserve FindPath(1 To Counter)
                        ReDim Preserve FindText(1 To Counter)
                        FindCell(Counter) = Cell.Address(False, False)
                        FindText(Counter) = Cell.Text
                        FindSheet(Counter) = WS.Name
                        FindWorkBook(Counter) = WB.Name
                        FindPath(Counter) = WB.FullName
                        Set Cell = .FindNext(Cell)
                    Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                End If
            End With
        End If
    Next
     
     'If no result found, reset properties and exit sub
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
         'Clear old results if required
         'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
         '**********************************
        GoTo Cancelled
    End If
     
     'Add SearchWord sheet if not present
    On Error Resume Next
    Sheets("SearchWord").Select
    If Err <> 0 Then
        ThisWorkbook.Sheets("SearchWord").Copy Before:=ActiveWorkbook.Worksheets(1)
    End If
     
    On Error GoTo Cancelled
     
     'Clear old data and then format results page as required
    Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
    Range("A1:P1").Interior.ColorIndex = 6
    Range("A1").Value = "Occurences of:"
    If Reset = True Then Range("B1").Value = Search
    Range("A1:P1").Font.Bold = True
    Range("B1").Value = "Client Name"
    Range("C1").Value = "Date"
    Range("D1").Value = "Day of Week"
    Range("E1").Value = "Modifier 1st"
    Range("F1").Value = "Proc. Code 1st"
    Range("G1").Value = "15 Min. Unit"
    Range("H1").Value = "Hrs 1st"
    Range("I1").Value = "Time In (1st)"
    Range("J1").Value = "Time Out (1st)"
    Range("K1").Value = "Time In (2nd)"
    Range("L1").Value = "Time Out (2nd)"
    Range("M1").Value = "Modifier 2nd"
    Range("N1").Value = "Proc. Code 2nd"
    Range("O1").Value = "15 Min. Unit"
    Range("P1").Value = "Hrs 2nd"
    Range("A1:P1").HorizontalAlignment = xlCenter
   
    With Columns("A:A")
        .ColumnWidth = 29
        .VerticalAlignment = xlCenter
    End With
    With Columns("B:B")
        .ColumnWidth = 18
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
     With Columns("C:C")
        .ColumnWidth = 8.43
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With Columns("D:D")
        .ColumnWidth = 10.14
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With Columns("E:P")
        .ColumnWidth = 9
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With Columns("E:J")
        .Interior.ColorIndex = 34
    End With
   With Columns("K:P")
      .Interior.ColorIndex = 36
   End With
     
     
     
     'Add hyperlinks and results to spreadsheet
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
        Address:="", SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
        TextToDisplay:=FindSheet(Counter) & " - " & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
         
         'Add text from offset columns; probably not
         'appropriate with whole sheet search
        Range("C" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -14)
        Range("D" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -13)
        Range("E" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -12)
        Range("F" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -11)
        Range("G" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -10)
        Range("H" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -9)
        Range("I" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -8)
        Range("J" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -7)
        Range("K" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -6)
        Range("L" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -5)
        Range("M" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -4)
        Range("N" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -3)
        Range("O" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -2)
        Range("P" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -1)
         '*********************************************
    Next Counter
     
     'Find search term on results page and colour text
    ColourText
     
Cancelled:
     
    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
     
End Sub
 
Sub ColourText()
    Dim Strt As Long, x As Long, i As Long
    Columns("B:B").Characters.Font.ColorIndex = xlAutomatic
    For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
        x = 1
        Do
            Strt = InStr(x, Range("B" & i), [B1], 1)
            If Strt = 0 Then Exit Do
            Range("B" & i).Characters(Start:=Strt, _
            Length:=Len([B1])).Font.ColorIndex = 7
            x = Strt + 1
        Loop
    Next
End Sub
And then modified the "SearchWord" page to autosort by date.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target(1, 1), Range("A:P")) Is Nothing Then
        Range("A:P").Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End If
End Sub
But is there any way to set searchword to search for an array of client names all in one go? That way I could have one page to print to have for my records.

But...At the same time each client name should still be sorted by date.

Thanks
 
Upvote 0
Here's a few minor tweaks to make it run perfect. This will have to do for now I can just search the clients one by one.

Code: 
'In the SearchWord sheet
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$B$1" Then
        Application.Run "SearchWord.xla!FindAll", Target.Text, "False"
        Cells(1, 2).Select
    End If
End Sub
 
 'In ThisWorkbook of the Add-In
Option Explicit
Private Sub Workbook_AddinInstall()
    On Error Resume Next
    Application.CommandBars("Tools").Controls("Search &word").Delete
    On Error GoTo 0
    With Application.CommandBars("Tools").Controls.Add
        .Caption = "Search &word"
        .Tag = "Search word"
        .OnAction = "'" & ThisWorkbook.Name & "'!Search.DoFindAll"
    End With
    MsgBox "'Search word' option added to Tools menu"
End Sub
 
Private Sub Workbook_AddinUninstall()
    On Error Resume Next
    Application.CommandBars("Tools").Controls("Search &word").Delete
End Sub
 
 'In a module of the Add-In
Option Compare Text
Option Explicit
 
Public Sub DoFindAll()
    FindAll "", "True"
End Sub
 
Public Sub FindAll(Search As String, Reset As Boolean)
     
    Dim WB              As Workbook
    Dim WS              As Worksheet
    Dim Cell            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim FindCell()      As String
    Dim FindSheet()     As String
    Dim FindWorkBook()  As String
    Dim FindPath()      As String
    Dim FindText()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim Path            As String
     
    If Search = "" Then
        Prompt = "What do you want to search for in the worbook: " & _
        vbNewLine & vbNewLine & Path
        Title = "Search Criteria Input"
        Search = InputBox(Prompt, Title, "Enter search term")
        If Search = "" Then
            GoTo Cancelled
        End If
    End If
     
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    On Error GoTo Cancelled
     
    Set WB = ActiveWorkbook
    For Each WS In WB.Worksheets
        If WS.Name <> "SearchWord" Then
             'Search whole sheet
             'With WB.Sheets(WS.Name).Cells
             '***********************************
             'Alternative to search single column
            With WB.Sheets(WS.Name).Range("O:O")
                 '***********************************
                Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
                MatchCase:=False, SearchOrder:=xlByColumns)
                If Not Cell Is Nothing Then
                    FirstAddress = Cell.Address
                    Do
                        Counter = Counter + 1
                        ReDim Preserve FindCell(1 To Counter)
                        ReDim Preserve FindSheet(1 To Counter)
                        ReDim Preserve FindWorkBook(1 To Counter)
                        ReDim Preserve FindPath(1 To Counter)
                        ReDim Preserve FindText(1 To Counter)
                        FindCell(Counter) = Cell.Address(False, False)
                        FindText(Counter) = Cell.Text
                        FindSheet(Counter) = WS.Name
                        FindWorkBook(Counter) = WB.Name
                        FindPath(Counter) = WB.FullName
                        Set Cell = .FindNext(Cell)
                    Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                End If
            End With
        End If
    Next
     
     'If no result found, reset properties and exit sub
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
         'Clear old results if required
         'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
         '**********************************
        GoTo Cancelled
    End If
     
     'Add SearchWord sheet if not present
    On Error Resume Next
    Sheets("SearchWord").Select
    If Err <> 0 Then
        ThisWorkbook.Sheets("SearchWord").Copy Before:=ActiveWorkbook.Worksheets(1)
    End If
     
    On Error GoTo Cancelled
     
     'Clear old data and then format results page as required
    Range("A2", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
    Range("A1:P1").Interior.ColorIndex = 6
    Range("A1").Value = "Occurences of:"
    If Reset = True Then Range("B1").Value = Search
    Range("A1:P1").Font.Bold = True
    Range("B1").Value = "Client Name"
    Range("C1").Value = "Date"
    Range("D1").Value = "Day of Week"
    Range("E1").Value = "Modifier 1st"
    Range("F1").Value = "Proc. Code 1st"
    Range("G1").Value = "15 Min. Unit"
    Range("H1").Value = "Hrs 1st"
    Range("I1").Value = "Time In (1st)"
    Range("J1").Value = "Time Out (1st)"
    Range("K1").Value = "Time In (2nd)"
    Range("L1").Value = "Time Out (2nd)"
    Range("M1").Value = "Modifier 2nd"
    Range("N1").Value = "Proc. Code 2nd"
    Range("O1").Value = "15 Min. Unit"
    Range("P1").Value = "Hrs 2nd"
    Range("A1:P1").HorizontalAlignment = xlCenter
    Range("A2:J999").HorizontalAlignment = xlLeft
    Range("K2:P999").HorizontalAlignment = xlRight
    
    With Columns("A:A")
        .ColumnWidth = 29
        .VerticalAlignment = xlCenter
    End With
    With Columns("B:B")
        .ColumnWidth = 18
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
     With Columns("C:C")
        .ColumnWidth = 8.43
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With Columns("D:D")
        .ColumnWidth = 10.14
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With Columns("E:P")
        .ColumnWidth = 9
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With Columns("E:J")
        .Interior.ColorIndex = 34
    End With
   With Columns("K:P")
      .Interior.ColorIndex = 36
   End With
     
     
     
     'Add hyperlinks and results to spreadsheet
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
        Address:="", SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
        TextToDisplay:=FindSheet(Counter) & " - " & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
         
         'Add text from offset columns; probably not
         'appropriate with whole sheet search
        Range("C" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -14)
        Range("D" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -13)
        Range("E" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -12)
        Range("F" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -11)
        Range("G" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -10)
        Range("H" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -9)
        Range("I" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -8)
        Range("J" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -7)
        Range("K" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -6)
        Range("L" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -5)
        Range("M" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -4)
        Range("N" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -3)
        Range("O" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -2)
        Range("P" & Counter + 2).Value = _
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, -1)
         '*********************************************
    Next Counter
     
     'Find search term on results page and colour text
    ColourText
     
Cancelled:
     
    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
     
End Sub
 
Sub ColourText()
    Dim Strt As Long, x As Long, i As Long
    Columns("B:B").Characters.Font.ColorIndex = xlAutomatic
    For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
        x = 1
        Do
            Strt = InStr(x, Range("B" & i), [B1], 1)
            If Strt = 0 Then Exit Do
            Range("B" & i).Characters(Start:=Strt, _
            Length:=Len([B1])).Font.ColorIndex = 7
            x = Strt + 1
        Loop
    Next
End Sub

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target(1, 1), Range("A:P")) Is Nothing Then
        Range("A3:P999").Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End If
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Locked
  • Question Question
Still need help on a daily summary sheet
Replies
1
Views
604
Fluff
Fluff
L
  • Solved
VBA Find Cell from Date listed, in Columns, Return cell to highlight in color
Replies
7
Views
528
mumps
mumps
P
  • Question Question
Automating copying of columns within same sheet in excel using VBA.
Replies
1
Views
659
MountainFog
M
S
  • Question Question
Searching Sheet Names using a wildcard
Replies
5
Views
296
mumps
mumps
J
  • Question Question
Daily summary worksheet that extracts data from up to 40 worksheets and emails the sheet as an excel attachment.
Replies
4
Views
552
juscuz419
J

Forum statistics

Threads
1,224,568
Messages
6,179,595
Members
452,927
Latest member
whitfieldcraig

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