none
Excel VB Code RRS feed

  • Question

  • Dear Community,

    I have an extremely limited understanding of VB code......so what I have included below may only need some twigging.

    I've searched high and low and am a little stuck.

    Let's say I have an Excel spreadsheet with 3 sheets (or even an 30) , all with the same headers.

    NAME|ACTIVITY 1|ACTIVITY 2|ACTIVITY 3|ACTIVITY 4|ACTIVITY 5|

    The sheets may have more headers.....but they would all be the same.

    I want to search ALL columns on all sheets under the headers for a specific word....lets say Tennis.

    It could appear in any column under any header on possibly multiple sheets, even column 1...(but not in this case)

    ......

    I've realised there is several parts to the code

    1-An input box for the text to be searched

    2-filter the sheets

    3-copy the filtered information into a new sheet (tab with same name as the entered text in the input box)

    4-remove the filters

    5-close the VB window.

    Is anyone able to help me. It's probably 30 lines of code. I located some code from versions sources and came up with the following but it doesn't work. to what I want it to do.

    PART 1 - This step was very easy

    from - www.excel-pratique.com/en/vba/dialog_boxes.php

         MYsearch= InputBox("What are you searching for?", "Search Box")

    PART 2 - This only works on the first column. Is there a way to search all used ranges?

    From - www.extendoffice.com/documents/excel/3704-excel-filter-across-multiple-sheets.html

     Dim xWs As Worksheet
        On Error Resume Next
        For Each xWs In Worksheets
            xWs.Range("A1").AutoFilter 1, "="+MYsearch
        Next


    Part 3 - Basically this didn't work when I placed under the code from Part 2

    from  - www.extendoffice.com/documents/excel/1184-excel-merge-multiple-worksheets-into-one.html

    Sub Combine()
    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = MYsearch
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    For J = 2 To Sheets.Count
    Sheets(J).Activate
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
    Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next
    End Sub


    PART 4 - I was not able to get this to work

    From - www.contextures.com/xlautofilter03.html

    * Worksheets("Data").AutoFilterMode = False

    Part 5 - I couldn't get this to work for these codes I found on various sites

    * oVBe.VBE.MainWindow.Visible = False

    * Application.VBE.MainWindow.Visible = False
    * Application.ShowVisualBasicEditor = False



    • Edited by Bunass01 Tuesday, November 1, 2016 3:13 PM
    Tuesday, November 1, 2016 2:53 PM

Answers

  • Hi,

    For the header, do you refer to the page header or the table header? And I don’t understand what is the relationship between the header and the search.

    I think your requirement is that search all the sheets for a specific record and then collect the results in a new sheet.

    Filtering is not proper for your case. It is fine if you want to search in one column. However, when searching in the whole sheet, if there are two cells in different rows, you could only get one by filtering all columns.

    Part5 is unnecessary. We don’t need to close the VBE when running a macro.

    You could test the code below. It searches all the sheets and paste the result rows in the new sheet "test".

    Sub Demo()
    Dim mySearch As String
    Dim ws As Worksheet
    Dim rslws As Worksheet
    Dim searchRange As Range
    Dim foundcells As Range
    Dim foundcell As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    mySearch = InputBox("What are you searching for?", "Search Box")
    i = 1
    'Set rslws = ThisWorkbook.Worksheets("test")
    Set rslws = ThisWorkbook.Worksheets.Add
    rslws.Name = "test"
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "test" Then
    Set searchRange = ws.UsedRange
    Set foundcells = FindAll(searchRange, mySearch)
       If foundcells Is Nothing Then
            MsgBox "Value Not Found in sheet " & ws.Name
        Else
            For Each foundcell In foundcells
            foundcell.EntireRow.Copy
            rslws.Cells(i, 1).PasteSpecial (xlPasteAll)
            i = i + 1
            Next foundcell
        End If
    End If
    Next ws
    MsgBox "Done"
    Application.CutCopyMode = False
    End Sub
    'The funtion comes from http://www.cpearson.com/excel/findall.aspx
    Function FindAll(searchRange As Range, _
                    FindWhat As Variant, _
                   Optional LookIn As XlFindLookIn = xlValues, _
                    Optional LookAt As XlLookAt = xlWhole, _
                    Optional SearchOrder As XlSearchOrder = xlByRows, _
                    Optional MatchCase As Boolean = False, _
                    Optional BeginsWith As String = vbNullString, _
                    Optional EndsWith As String = vbNullString, _
                    Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
    Dim foundcell As Range
    Dim FirstFound As Range
    Dim lastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean
    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If
    For Each Area In searchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set lastCell = searchRange.Worksheet.Cells(MaxRow, MaxCol)
    On Error GoTo 0
    Set foundcell = searchRange.Find(what:=FindWhat, _
            after:=lastCell, _
            LookIn:=LookIn, _
            LookAt:=XLookAt, _
            SearchOrder:=SearchOrder, _
            MatchCase:=MatchCase)
    If Not foundcell Is Nothing Then
        Set FirstFound = foundcell
        Do Until False ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(foundcell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(foundcell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = foundcell
                Else
                    Set ResultRange = Application.Union(ResultRange, foundcell)
                End If
            End If
            Set foundcell = searchRange.FindNext(after:=foundcell)
            If (foundcell Is Nothing) Then
                Exit Do
            End If
            If (foundcell.Address = FirstFound.Address) Then
                Exit Do
            End If
       Loop
    End If
    Set FindAll = ResultRange
    End Function
    
    

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Proposed as answer by Vishwamitra Mishra Wednesday, November 2, 2016 3:27 PM
    • Marked as answer by Bunass01 Monday, November 7, 2016 9:39 AM
    Wednesday, November 2, 2016 6:52 AM
    Moderator
  • Hi,

    Update: I add a tag "Location" to enable a new search.

    Note: if there two or more value in the same row, the record would be duplicated.

    Sub Demo()
    Dim mySearch As String
    Dim ws As Worksheet
    Dim rslws As Worksheet
    Dim searchRange As Range
    Dim foundcells As Range
    Dim foundcell As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    mySearch = InputBox("What are you searching for?", "Search Box")
    
    On Error Resume Next
    Sheets("test").Activate
    If Err = 0 Then
    Set rslws = ThisWorkbook.Worksheets("test")
    Else
    Set rslws = ThisWorkbook.Worksheets.Add
    rslws.Name = "test"
    End If
    Sheets("Sheet1").Range("A1:F1").Copy Destination:=Sheets("test").Range("A1:F1")
    rslws.Range("G1").Value = "Location"
    i = Sheets("test").UsedRange.Rows.Count
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "test" Then
    Set searchRange = ws.UsedRange
    Set foundcells = FindAll(searchRange, mySearch)
       If Not foundcells Is Nothing Then
            For Each foundcell In foundcells
            If rslws.Columns("G").Find(ws.Name & foundcell.Address) Is Nothing Then
            foundcell.EntireRow.Copy
            rslws.Cells(i + 1, 1).PasteSpecial (xlPasteAll)
            rslws.Cells(i + 1, 7).Value = ws.Name & foundcell.Address
            i = i + 1
            End If
            Next foundcell
        End If
    End If
    Next ws
    MsgBox "Done"
    Application.CutCopyMode = False
    End Sub
    

    >>The reason I wanted to close the VB window enable quick access back to the spreadsheet. IS there code that can do this? I tried adding the 3 options I had above but no luck.

    I think you run the macro when VBA Editor opened (F5 to run the macro in VBE), so you want to close it to come back.

    In fact, you could show the Developer Tab (see How to: Show the Developer Tab on the Ribbon), click Macro to open the list, then you could run the macro. Besides, you could assign a shortcut key to the macro. Please see the pictures below.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Bunass01 Monday, November 7, 2016 9:38 AM
    Thursday, November 3, 2016 5:39 AM
    Moderator

All replies

  • Hi 

    this is too much of information but what is missing is basically the summary like what you want to search and if search found what you want to do with that record?


    Vish Mishra

    Tuesday, November 1, 2016 8:14 PM
  • Hi,

    For the header, do you refer to the page header or the table header? And I don’t understand what is the relationship between the header and the search.

    I think your requirement is that search all the sheets for a specific record and then collect the results in a new sheet.

    Filtering is not proper for your case. It is fine if you want to search in one column. However, when searching in the whole sheet, if there are two cells in different rows, you could only get one by filtering all columns.

    Part5 is unnecessary. We don’t need to close the VBE when running a macro.

    You could test the code below. It searches all the sheets and paste the result rows in the new sheet "test".

    Sub Demo()
    Dim mySearch As String
    Dim ws As Worksheet
    Dim rslws As Worksheet
    Dim searchRange As Range
    Dim foundcells As Range
    Dim foundcell As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    mySearch = InputBox("What are you searching for?", "Search Box")
    i = 1
    'Set rslws = ThisWorkbook.Worksheets("test")
    Set rslws = ThisWorkbook.Worksheets.Add
    rslws.Name = "test"
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "test" Then
    Set searchRange = ws.UsedRange
    Set foundcells = FindAll(searchRange, mySearch)
       If foundcells Is Nothing Then
            MsgBox "Value Not Found in sheet " & ws.Name
        Else
            For Each foundcell In foundcells
            foundcell.EntireRow.Copy
            rslws.Cells(i, 1).PasteSpecial (xlPasteAll)
            i = i + 1
            Next foundcell
        End If
    End If
    Next ws
    MsgBox "Done"
    Application.CutCopyMode = False
    End Sub
    'The funtion comes from http://www.cpearson.com/excel/findall.aspx
    Function FindAll(searchRange As Range, _
                    FindWhat As Variant, _
                   Optional LookIn As XlFindLookIn = xlValues, _
                    Optional LookAt As XlLookAt = xlWhole, _
                    Optional SearchOrder As XlSearchOrder = xlByRows, _
                    Optional MatchCase As Boolean = False, _
                    Optional BeginsWith As String = vbNullString, _
                    Optional EndsWith As String = vbNullString, _
                    Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
    Dim foundcell As Range
    Dim FirstFound As Range
    Dim lastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean
    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If
    For Each Area In searchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set lastCell = searchRange.Worksheet.Cells(MaxRow, MaxCol)
    On Error GoTo 0
    Set foundcell = searchRange.Find(what:=FindWhat, _
            after:=lastCell, _
            LookIn:=LookIn, _
            LookAt:=XLookAt, _
            SearchOrder:=SearchOrder, _
            MatchCase:=MatchCase)
    If Not foundcell Is Nothing Then
        Set FirstFound = foundcell
        Do Until False ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(foundcell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(foundcell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = foundcell
                Else
                    Set ResultRange = Application.Union(ResultRange, foundcell)
                End If
            End If
            Set foundcell = searchRange.FindNext(after:=foundcell)
            If (foundcell Is Nothing) Then
                Exit Do
            End If
            If (foundcell.Address = FirstFound.Address) Then
                Exit Do
            End If
       Loop
    End If
    Set FindAll = ResultRange
    End Function
    
    

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Proposed as answer by Vishwamitra Mishra Wednesday, November 2, 2016 3:27 PM
    • Marked as answer by Bunass01 Monday, November 7, 2016 9:39 AM
    Wednesday, November 2, 2016 6:52 AM
    Moderator
  • Dear Celeste.

    Thank you for this. :-)

    I ran it and it worked. ...with one or two small issues, but the code did what I was trying to do. :-)

    One strange issue was when I typed in a search for a name in the first column I got the msg box 'Value Not Found in Sheet Sheet 1'. Then I got the same thing happen with reference to 'sheet 2'. But after click on the ok in both instances it put the result in the new sheet.

    The headers are at the top of each sheet are the same for all sheets in the workbook.

    NAME|ACTIVITY 1|ACTIVITY 2|ACTIVITY 3|ACTIVITY 4|ACTIVITY 5|

    I want to have these headers on the Test Sheet. s well and is there a code to add to make the test sheet the last one (or first if that's not possible) of the sheets along the bottom tabs  of the workbook?

    The reason I wanted to close the VB window enable quick access back to the spreadsheet. IS there code that can do this? I tried adding the 3 options I had above but no luck.

    What can be added to enable a new search that omits duplication in any previous search(es)?

    Thank you in advance.

    • Edited by Bunass01 Wednesday, November 2, 2016 3:23 PM
    Wednesday, November 2, 2016 2:30 PM
  • Thank you Vish for your reply.

    The code Celeste present below is almost what I am trying to do.

    After the search I want the results to appear on a new sheet in the workbook, ideally with the headers and preferably at the end of the list of sheets (tabs) across the bottom of the workbook. The final part if to close the VB window.

    Wednesday, November 2, 2016 2:33 PM
  • Hi,

    Update: I add a tag "Location" to enable a new search.

    Note: if there two or more value in the same row, the record would be duplicated.

    Sub Demo()
    Dim mySearch As String
    Dim ws As Worksheet
    Dim rslws As Worksheet
    Dim searchRange As Range
    Dim foundcells As Range
    Dim foundcell As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    mySearch = InputBox("What are you searching for?", "Search Box")
    
    On Error Resume Next
    Sheets("test").Activate
    If Err = 0 Then
    Set rslws = ThisWorkbook.Worksheets("test")
    Else
    Set rslws = ThisWorkbook.Worksheets.Add
    rslws.Name = "test"
    End If
    Sheets("Sheet1").Range("A1:F1").Copy Destination:=Sheets("test").Range("A1:F1")
    rslws.Range("G1").Value = "Location"
    i = Sheets("test").UsedRange.Rows.Count
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "test" Then
    Set searchRange = ws.UsedRange
    Set foundcells = FindAll(searchRange, mySearch)
       If Not foundcells Is Nothing Then
            For Each foundcell In foundcells
            If rslws.Columns("G").Find(ws.Name & foundcell.Address) Is Nothing Then
            foundcell.EntireRow.Copy
            rslws.Cells(i + 1, 1).PasteSpecial (xlPasteAll)
            rslws.Cells(i + 1, 7).Value = ws.Name & foundcell.Address
            i = i + 1
            End If
            Next foundcell
        End If
    End If
    Next ws
    MsgBox "Done"
    Application.CutCopyMode = False
    End Sub
    

    >>The reason I wanted to close the VB window enable quick access back to the spreadsheet. IS there code that can do this? I tried adding the 3 options I had above but no luck.

    I think you run the macro when VBA Editor opened (F5 to run the macro in VBE), so you want to close it to come back.

    In fact, you could show the Developer Tab (see How to: Show the Developer Tab on the Ribbon), click Macro to open the list, then you could run the macro. Besides, you could assign a shortcut key to the macro. Please see the pictures below.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by Bunass01 Monday, November 7, 2016 9:38 AM
    Thursday, November 3, 2016 5:39 AM
    Moderator
  • Thank you Celeste for this.

    Is didn't fully work. I got the headings, thank you :-), but the tab ended up being the 3rd one across and a new column appears called location. Showing the original sheet location for each item that matched the search criteria. Example - Sheet1$E$

    I am wondering, if I repeat the search for a different search word, it will obviousely include the 'test' results. If I hide the tab and repeat the search the programme fails. Is there something that can be added to exclude any hidden sheets? I found this online which I know it's something to do with Activesheets or a sheet being visible? But I couldn't work it out. 

    http://stackoverflow.com/questions/29415951/vba-ignoring-hidden-worksheets-saving-specific-worksheets-as-pdf

    Your time is appreciated. Thank you in advance.

    Saturday, November 5, 2016 2:47 AM
  • >>the tab ended up being the 3rd one across and a new column appears called location. Showing the original sheet location for each item that matched the search criteria. Example - Sheet1$E$


    This column is added to identify if the record is added to the "test" sheet.

    The logic for the project is searching the value and adding to the "test" sheet, so if you search a same value again, the record would be added again. To avoid this situation, I add a tag called location to let Excel skip the records which have been added. You could use the previous version if you wouldn’t search a value again.

     

    Since this original issue has been resolved and the second issue is different from the original one, I suggest you create and post new thread for new issues. More community members and we would help you to focus on the specific issue.

    Thanks for your understanding.

    Regards.

    Celeste



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, November 7, 2016 5:40 AM
    Moderator
  • Will do. THnaks Celeste.
    Monday, November 7, 2016 9:37 AM