Search Multiple Sheets and Display Results on Sheet

[tommot]

Hi,

Apologies if similar questions have been asked, but:

I have a workbook which holds a list of jobs to be completed in a building with 6 sheets in it (Room 1 -5 and Results), each sheet is for a different room in the building and contains the same standard column titles, i.e. Job, Date Raised, Status and Additional Info (Column A-D).

I would like to be able to create Macros that will search through the five sheets and display the results on the Results sheet. I want the search to look in the Status column, where the option is either Open, Ongoing or Closed and want them to display the whole of that job, i.e. Columns A-D and not just column C.

Is this possible? and / or do you require more information to see what I am talking about?

Any help appreciated.

 

[davesweep]

Hi,

So you want to display a results sheet that will return all the closed items in the other 5 sheets? Can you post an example of the data you have?

Dave

 

[tommot]

Hi,

The workbook is not populated at the moment, as I am just testing some ideas, but data will look something like this on the sheets.


<TABLE style="WIDTH: 261pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=347 border=0 x:str><COLGROUP><COL style="WIDTH: 88pt; mso-width-source: userset; mso-width-alt: 4278" width=117><COL style="WIDTH: 62pt; mso-width-source: userset; mso-width-alt: 3035" width=83><COL style="WIDTH: 35pt; mso-width-source: userset; mso-width-alt: 1682" width=46><COL style="WIDTH: 76pt; mso-width-source: userset; mso-width-alt: 3693" width=101><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD class=xl22 style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; WIDTH: 88pt; BORDER-BOTTOM: #c0c0c0; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" width=117 height=17>Job</TD><TD class=xl22 style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; WIDTH: 62pt; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent" width=83>Date Raised</TD><TD class=xl22 style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; WIDTH: 35pt; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent" width=46>Status</TD><TD class=xl22 style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; WIDTH: 76pt; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent" width=101>Additional Info</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>Replace Light</TD><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent">21.08.08</TD><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent">Open</TD><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent">N/A</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>Broken Door Hinge</TD><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent">21.08.08</TD><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent">Closed</TD><TD style="BORDER-RIGHT: #c0c0c0; BORDER-TOP: #c0c0c0; BORDER-LEFT: #c0c0c0; BORDER-BOTTOM: #c0c0c0; BACKGROUND-COLOR: transparent">£15 cost</TD></TR></TBODY></TABLE>


I would like to be able to search for Open, Closed and Ongoing jobs.

Thanks,

 

[Case_Germany]

Hi,

give it a try:

Public Sub Test()
    Dim intLastColumn As Integer
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    Dim strFound As String
    Dim rngRange As Range
    Dim strLink As String
    Dim strTMP As String
    On Error GoTo Test_Error
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Visible = True Then
            If wksSheet.Name Like "Found_*" Then
                Application.DisplayAlerts = False
                wksSheet.Delete
                Application.DisplayAlerts = True
            End If
        End If
    Next wksSheet
    strFound = InputBox("Enter word!", "Search", "Open")
    If strFound = "" Then Exit Sub
    Set wksSheetNew = Worksheets.Add(before:=Sheets(1))
    wksSheetNew.Name = "Found_" & Format(Now, "dd_mm_yy_hh_mm_ss")
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name <> wksSheetNew.Name And wksSheet.Visible = True Then
            Set rngRange = wksSheet.Columns(3).Find(What:=strFound, LookIn:=xlValues, LookAt:=xlPart)
            If rngRange Is Nothing Then
            Else
                strLink = rngRange.Value
            End If
            If Not rngRange Is Nothing Then
                strTMP = rngRange.Address
                Do
                    lngLastRow = lngLastRow + 1
                    wksSheet.Cells(rngRange.Row, rngRange.Column).EntireRow.Copy Destination:=wksSheetNew.Cells(lngLastRow, 1)
                    intLastColumn = Cells(lngLastRow, Columns.Count).End(xlToLeft).Column + 1
                    Cells(lngLastRow, intLastColumn).Value = "Sheet"
                    wksSheetNew.Hyperlinks.Add Anchor:=wksSheetNew.Cells(lngLastRow, intLastColumn), Address:="", _
                        SubAddress:=wksSheet.Name & "!" & rngRange.Address, TextToDisplay:="Found in Sheet " _
                        & wksSheet.Name & " " & rngRange.Address
                    Set rngRange = wksSheet.Columns(3).FindNext(rngRange)
                Loop While rngRange.Address <> strTMP
                wksSheetNew.Columns("A:G").AutoFit
            End If
        End If
    Next wksSheet
    If strTMP = "" Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Visible = True Then
                If wksSheet.Name Like "Found_*" Then
                    Application.DisplayAlerts = False
                    wksSheet.Delete
                    Application.DisplayAlerts = True
                End If
            End If
        Next wksSheet
        MsgBox "Search word was not found!"
    End If
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
    On Error GoTo 0
    Exit Sub
Test_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Visible = True Then
            If wksSheet.Name Like "Found_*" Then
                Application.DisplayAlerts = False
                wksSheet.Delete
                Application.DisplayAlerts = True
            End If
        End If
    Next wksSheet
    Set rngRange = Nothing
    Set wksSheetNew = Nothing
End Sub

Case_Germany

 

[tommot]

Thank you for your reply. It certainly works, but not quite the way I had pictured it.

I have to be honest and say that the code is slightly more complicated than I usually work with. So, I think I shall have to try and do it in a different way.

Thanks for your help though.