locked
VBA for Excel Help RRS feed

  • Question

  • Dear Community Members.

    I have a piece of code, with help from Celeste - thank you :-) , to search a Excels sheets for a specific word(s).

    Presentably it works.

    Please note - I have an extremely limited understanding of VB code.

    I want the following to happen in the code;

    1) if I repeat the search for a different search word, it will obviously 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?

    2) In the code there is a section to indicate there was nothing found in the search in a specific sheet. At the end of the code I want it to not state the MsgBox "Click on the " + mySearch + " tab to see the search results.", , "Search Complete!"

    if there are no results at all. Should this be the case the newly created sheet should be deleted.

    3) If the search is repeated, due to new data being added, the search sheet, with the same name, should be cleared/deleted and a new result should be put in the new sheet. A msgbox should be included to check that I actually want to clear the data - if no then a new list is created with another msgbox  or end the programme

    Many thanks in advance.

    HERE IS THE CODE

    Sub Search()
    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 = 2
    
    'Headings added
    Sheets(1).Select
    Worksheets.Add
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    
    'Naming Sheet 1 the search
    Set rslws = Sheets(1)
    rslws.Name = mySearch
    
    'Continuing with the programme
    
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> mySearch Then
    Set searchRange = ws.UsedRange
    Set foundcells = FindAll(searchRange, mySearch)
       If foundcells Is Nothing Then
       
            MsgBox "There were no results for '" + mySearch + "' in " & 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 "Click on the " + mySearch + " tab to see the search results.", , "Search Complete!"
    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
    
    
    
    

    Monday, November 7, 2016 10:16 AM

Answers

  • Hi,

    You just need to copy the code in my first and second reply.

    Use them at the same time. Then you could see the macro in the dialog. 

    Try and if you have any issues, please feel free to let me know.

    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 Sunday, November 27, 2016 4:12 AM
    Thursday, November 24, 2016 11:37 AM

All replies

  • Hi,

    This is the forum to discuss questions and feedback for Microsoft Excel, I'll move your question to the MSDN forum for Excel

    https://social.msdn.microsoft.com/Forums/en-US/home?forum=exceldev

    The reason why we recommend posting appropriately is you will get the most qualified pool of respondents, and other partners who read the forums regularly can either share their knowledge or learn from your interaction with us. Thank you for your understanding.


    Regards,
    Emi Zhang
    TechNet Community Support

    Please remember to mark the replies as answers if they helped.
    If you have feedback for TechNet Subscriber Support, contact tnmff@microsoft.com.



    Tuesday, November 8, 2016 7:25 AM
  • Hi,

    1)You could not use Sheets(1), Sheets(2) to refer to the sheets.

    When you repeat the search, it would refer to wrong sheets. I suggest you use name like Sheets("Sheet1") 

    I suggest you use the following code for the two parts. And I test it works for a different search word, even you hide the sheets.

     
    Dim oldWS As Worksheet
    'Headings added
    Set oldWS = ActiveSheet 'set current sheet where you search or you could use Sheets("name")
    Set rslws = Worksheets.Add(After:=oldWS)
    oldWS.Select
    oldWS.Range("A1").EntireRow.Select
    Selection.Copy Destination:=rslws.Range("A1")
     
    'Naming new Sheet
    rslws.Name = mySearch

    2)I think it is improper to delete the sheet in the For Loop.

    I suggest you check if there are records added into the new sheet.

    Use the code below before line  MsgBox "Click on the " + mySearch + " tab to see the search results.", , "Search Complete!"

    For Each ws In ThisWorkbook.Worksheets
    If ws.Name = mySearch Then
    If ws.UsedRange.Rows.Count = 1 Then
    ws.Delete
    MsgBox "Nothing found"
    Exit Sub
    End If
    End If
    Next ws
    

    Beside, we need to add Application.DisplayAlerts = False in the beginning and Application.DisplayAlerts = True in the end to remove the alert when deleting the sheet.

    3)Add the code below before search part

    For Each ws In ThisWorkbook.Worksheets
    If ws.Name = mySearch Then
    Dim answer As Integer
    answer = MsgBox("A new list?", vbYesNo)
    If answer = vbNo Then
      MsgBox "Cancel search"
      Exit Sub
    Else
    ws.Delete
    Exit For
    End If
    End If
    Next ws
    

    To avoid misunderstanding, the whole SUB:

    Sub search()
    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
    Application.DisplayAlerts = False
    
    mySearch = InputBox("What are you searching for?", "Search Box")
    i = 2
    
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name = mySearch Then
    Dim answer As Integer
    answer = MsgBox("A new list?", vbYesNo)
    If answer = vbNo Then
      MsgBox "Cancel search"
      Exit Sub
    Else
    ws.Delete
    Exit For
    End If
    End If
    Next ws
    
    Dim oldWS As Worksheet
    'Headings added
    Set oldWS = ActiveSheet 'set current sheet where you search or you could use Sheets("name")
    Set rslws = Worksheets.Add(After:=oldWS)
    oldWS.Select
    oldWS.Range("A1").EntireRow.Select
    Selection.Copy Destination:=rslws.Range("A1")
    
    'Continuing with the programme
    rslws.Name = mySearch
    
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> mySearch Then
    Set searchRange = ws.UsedRange
    Set foundcells = FindAll(searchRange, mySearch)
       If foundcells Is Nothing Then
        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
    
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name = mySearch Then
    If ws.UsedRange.Rows.Count = 1 Then
    ws.Delete
    MsgBox "Nothing found"
    Exit Sub
    End If
    End If
    Next ws
    
    MsgBox "Click on the " + mySearch + " tab to see the search results.", , "Search Complete!"
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    End Sub





    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 Chenchen Li Friday, November 18, 2016 9:16 AM
    Thursday, November 10, 2016 2:02 PM
  • Dear Emi,

    Thank you for moving the question to the appropriate place, but unfortunately I am unable to find it. The link provides me with all of the forum questions.

    By any chance can you give me the link to my specific question?

    Thank you

    Sunday, November 20, 2016 2:48 AM
  • Thank you for your response Celeste

    I tried running this but it didn't work. The code had an issue with this line

    Set foundcells = FindAll(searchRange, mySearch)

    It says sub or function not defined. I copied the whole sub and pasted it in.

    Sunday, November 20, 2016 2:53 AM
  • Hi,

    You could see your last thread: Excel VB Code to get the function.

    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
    


    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 21, 2016 1:49 AM
  • When I replaced this function code section and run it I have this come up.

    I think it it getting beyond my capabilities. Thank you anyway.

    Thursday, November 24, 2016 11:32 AM
  • Hi,

    You just need to copy the code in my first and second reply.

    Use them at the same time. Then you could see the macro in the dialog. 

    Try and if you have any issues, please feel free to let me know.

    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 Sunday, November 27, 2016 4:12 AM
    Thursday, November 24, 2016 11:37 AM
  • Thank you Celeste. That worked.
    Sunday, November 27, 2016 4:12 AM