Search for text throughout a workbook, make new sheet in a different workbook and loop with different search.

H

hellocroco

New Member
Joined
Jul 18, 2012
Messages
4
Hey Gurus,

This is my first time posting but I have a problem I just can't seem to crack. I have a workbook called "Transverse Series Slides.xlsm" that contains multiple worksheets with cells containing "label names" and their information. I need to search this workbook for instances of each label name, display them all on a new sheet, put this sheet in a new workbook (called "StructDB2.xlsm"), and rename the sheet to the contents of B1. Now this is only my first time using VBA, but I found a code online that was almost perfect and edited it to suit my needs. It works perfectly every time but it requires you to input your search terms in an InputBox each time. I was hoping I could write a loop so that it automatically goes through a certain range of cells in column B of yet another workbook ("The Matrix.xlsx") and uses each cell as the search term. I'm not sure how much of this I need to attach, if any, but please let me know if you cannot figure it out using only the codes below. Thank you so much for the help!

Original code from the web with the changes I made:

Code: 
Option Compare TextOption Explicit
 
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
 
Const SM_CXSCREEN = 0
 
 'Returns screen size to set display column width
Private Function ScreenWidth()
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function
 
Sub DoFindAll()
     'Arguments required for initial use in a workbook
    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 FindLabel()     As String
    Dim FindData()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim Path            As String
    Dim MyResponse      As VbMsgBoxResult
     
   
     
    If Search = "" Then
        Prompt = "What do you want to search for in the worbook: " & vbNewLine & vbNewLine & Path
        Title = "Search Criteria Input"
         'Delete default search term if required
        Search = InputBox(Prompt, Title, "Enter search term")
        If Search = "" Then
            GoTo Canceled
        End If
    End If
     
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
     'Save found addresses and text into arrays
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each WS In WB.Worksheets
             'Omit results page from search
            If WS.Name <> "FindWord" Then
                With WB.Sheets(WS.Name).Cells
                    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)
                            ReDim Preserve FindLabel(1 To Counter)
                            ReDim Preserve FindData(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindLabel(Counter) = Cell.Offset(, -1).Text
                            FindData(Counter) = Cell.Offset(, 1).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
    End If
    On Error GoTo 0
     'Response if no text found
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
        Exit Sub
    End If
     
     'Create FindWord sheet in does not exist
    On Error Resume Next
    Sheets("FindWord").Select
    If Err <> 0 Then
        Debug.Print Err
         'error occured so clear it
        Err.Clear
        Sheets.Add.Name = "FindWord"
        Sheets("FindWord").Move After:=Sheets(Sheets.Count)
         'Run macro to add code to ThisWorkbook
        AddSheetCode
    End If
     'Write hyperlinks and texts to FindWord
    Range("A3:B65536").ClearContents
    Range("A1:B1").Interior.ColorIndex = 45
    Range("A1").Value = "Occurences of:"
     'Reset prevents looping of code when sheet changes
    If Reset = True Then Range("B1").Value = Search
    Range("A1:D2").Font.Bold = True
    Range("A2").Value = "Location"
    Range("B2").Value = "Label Number"
    Range("C2").Value = "Name"
    Range("D2").Value = "Data"
    Range("A1:B1").HorizontalAlignment = xlLeft
    Range("A2:B2").HorizontalAlignment = xlCenter
     'Adjust column width to suit display
    Range("A:A").ColumnWidth = ScreenWidth / 60
    Range("B:B").ColumnWidth = ScreenWidth / 40
    Range("C:C").ColumnWidth = ScreenWidth / 20
    Range("D:D").ColumnWidth = ScreenWidth / 40
    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 = FindLabel(Counter)
        Range("C" & Counter + 2).Value = FindText(Counter)
        Range("D" & Counter + 2).Value = FindData(Counter)
    Next Counter
    Range("B1").Select
Canceled:
     
    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
Call findReplace
ActiveWorkbook.Save


End Sub
 
 
Sub AddSheetCode()
     'Thanks to Dragontooth
    Dim strCode As String
    Dim FWord As String
    Dim WB As Workbook
    Dim Sh
    Dim I As Integer
    Set WB = ActiveWorkbook
     
     'Line to be inserted instead of 4th line below if code in personal.xlsb
     '& "Application.Run (" & Chr(34) & "personal.xlsb!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
     'Optional 4th line if code in workbook
     '& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _


    strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _
    & "If Sh.Name = " & Chr(34) & "FindWord" & Chr(34) & " Then" & vbCr _
    & "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
    & "Application.Run (" & Chr(34) & "personal.xlsb!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    & "Cells(1,2).Select" & vbCr _
    & "End if" & vbCr _
    & "End if" & vbCr _
    & "End Sub"
     'Debug.Print strCode
     
     'Write code to ThisWorkbook module
    FWord = "ThisWorkbook"
    For I = 1 To WB.VBProject.VBComponents.Count
        If WB.VBProject.VBComponents.Item(I).Name = FWord Then
            Exit For
        End If
    Next
    If Not WB.VBProject.VBComponents.Item(I).CodeModule Is Nothing Then
        If Not WB.VBProject.VBComponents.Item(I).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then
            WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (strCode)
        End If
    End If
    Set WB = Nothing
     
End Sub

This code calls the findReplace Macro so here is that code

Code: 
Sub findReplace()'
' findReplace Macro
'


    Call move2StructDB
    
    Range("B1").Select
    ActiveCell.Replace What:="is ", Replacement:=""
    
    If InStr(Range("B1").Value, " [in region# 0]") Then
       Cells.Replace What:=" [in region# 0]", Replacement:=""
    
    ElseIf InStr(Range("B1").Value, " [in region# 1]") Then
        Cells.Replace What:=" [in region# 1]", Replacement:=" #1"
        
    ElseIf InStr(Range("B1").Value, " [in region# 2]") Then
        Cells.Replace What:=" [in region# 2]", Replacement:=" #2"
        
    End If
        
        
    Call renameSheet
    
End Sub
Sub renameSheet()
'
' renameSheet Macro


    Sheets("FindWord").Select
    Sheets("FindWord").Name = Range("B1").Value
End Sub
Sub move2StructDB()
'
' move2StructDB Macro
'


'
    Sheets("FindWord").Select
    Sheets("FindWord").Move After:=Workbooks("StructDB.xlsx").Worksheets(Workbooks("StructDB.xlsx").Worksheets.Count)
End Sub

Here is the code with the loop that I tried to make. I tried to change almost all the "Sub" names to "______Auto" so as not to avoid confusion but i may have made it worse..:confused:

Code: 
Option Compare TextOption Explicit
 
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
 
Const SM_CXSCREEN = 0
 
 'Returns screen size to set display column width
Private Function ScreenWidth()
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function
 
Sub DoFindAllAuto()
     'Arguments required for initial use in a workbook
    FindAllAuto "", "True"
End Sub
Public Sub FindAllAuto(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 FindLabel()     As String
    Dim FindData()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim Path            As String
    Dim MyResponse      As VbMsgBoxResult
     
   
If Search = "" Then
        'Prompt = "What do you want to search for in the worbook: " & vbNewLine & vbNewLine & Path
        'Title = "Search Criteria Input"
         'Delete default search term if required
        'Search = InputBox(Prompt, Title, "Enter search term")
        'If Search = "" Then
            'GoTo Canceled


For Each Cell In Workbooks("The Matrix.xlsx").Worksheets("The Matrix").Range("B2:B238")
            Search = Cell.Value
            
        
   'End If
     
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
     'Save found addresses and text into arrays
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each WS In WB.Worksheets
             'Omit results page from search
            If WS.Name <> "FindWord" Then
                With WB.Sheets(WS.Name).Cells
                    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)
                            ReDim Preserve FindLabel(1 To Counter)
                            ReDim Preserve FindData(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindLabel(Counter) = Cell.Offset(, -1).Text
                            FindData(Counter) = Cell.Offset(, 1).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
    End If
    On Error GoTo 0
     'Response if no text found
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
        Exit Sub
    End If
     
     'Create FindWord sheet in does not exist
    On Error Resume Next
    Sheets("FindWord").Select
    If Err <> 0 Then
        Debug.Print Err
         'error occured so clear it
        Err.Clear
        Sheets.Add.Name = "FindWord"
        Sheets("FindWord").Move After:=Sheets(Sheets.Count)
         'Run macro to add code to ThisWorkbook
        AddSheetCode
    End If
     'Write hyperlinks and texts to FindWord
    Range("A3:B65536").ClearContents
    Range("A1:B1").Interior.ColorIndex = 45
    Range("A1").Value = "Occurences of:"
     'Reset prevents looping of code when sheet changes
    If Reset = True Then Range("B1").Value = Search
    Range("A1:D2").Font.Bold = True
    Range("A2").Value = "Location"
    Range("B2").Value = "Label Number"
    Range("C2").Value = "Name"
    Range("D2").Value = "Data"
    Range("A1:B1").HorizontalAlignment = xlLeft
    Range("A2:B2").HorizontalAlignment = xlCenter
     'Adjust column width to suit display
    Range("A:A").ColumnWidth = ScreenWidth / 60
    Range("B:B").ColumnWidth = ScreenWidth / 40
    Range("C:C").ColumnWidth = ScreenWidth / 20
    Range("D:D").ColumnWidth = ScreenWidth / 40
    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 = FindLabel(Counter)
        Range("C" & Counter + 2).Value = FindText(Counter)
        Range("D" & Counter + 2).Value = FindData(Counter)
    Next Counter
    Range("B1").Select
Canceled:
     
    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    
    Call findReplaceAuto
Next Cell
End If
End Sub




Sub AddSheetCode()
     'Thanks to Dragontooth
    Dim strCode As String
    Dim FWord As String
    Dim WB As Workbook
    Dim Sh
    Dim I As Integer
    Set WB = ActiveWorkbook
     
     'Line to be inserted instead of 4th line below if code in personal.xlsb
     '& "Application.Run (" & Chr(34) & "personal.xlsb!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
     'Optional 4th line if code in workbook
     '& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _


    strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _
    & "If Sh.Name = " & Chr(34) & "FindWord" & Chr(34) & " Then" & vbCr _
    & "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
    & "Application.Run (" & Chr(34) & "personal.xlsb!Search.FindAllAuto" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    & "Cells(1,2).Select" & vbCr _
    & "End if" & vbCr _
    & "End if" & vbCr _
    & "End Sub"
     'Debug.Print strCode
     
     'Write code to ThisWorkbook module
    FWord = "ThisWorkbook"
    For I = 1 To WB.VBProject.VBComponents.Count
        If WB.VBProject.VBComponents.Item(I).Name = FWord Then
            Exit For
        End If
    Next
    If Not WB.VBProject.VBComponents.Item(I).CodeModule Is Nothing Then
        If Not WB.VBProject.VBComponents.Item(I).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then
            WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (strCode)
        End If
    End If
    Set WB = Nothing
     
End Sub

And lastly, here is the findReplaceAuto to go with SearchAuto...

Code: 
Sub findReplaceAuto()'
' findReplaceAuto Macro
'


    Call move2StructDB2
    
    Range("B1").Select
    ActiveCell.Replace What:="is ", Replacement:=""
    
    If InStr(Range("B1").Value, " [in region# 0]") Then
       ActiveCell.Replace What:=" [in region# 0]", Replacement:=""
    
    ElseIf InStr(Range("B1").Value, " [in region# 1]") Then
        ActiveCell.Replace What:=" [in region# 1]", Replacement:=" #1"
        
    ElseIf InStr(Range("B1").Value, " [in region# 2]") Then
        ActiveCell.Replace What:=" [in region# 2]", Replacement:=" #2"
        
    End If
        
        
    Call renameSheetAuto
    
End Sub
Sub renameSheetAuto()
'
' renameSheet Macro


    Sheets("FindWord").Select
    Sheets("FindWord").Name = Range("B1").Value
End Sub
Sub move2StructDB2()
'
' move2StructDB Macro
'


'
    Sheets("FindWord").Select
    Sheets("FindWord").Move After:=Workbooks("StructDB2.xlsx").Worksheets(Workbooks("StructDB2.xlsx").Worksheets.Count)
End Sub

I am sure a lot of my code is sloppy-- like I said this is my first time with VBA. Also, sorry for such a long post, but maybe someone will be kind enough to read it all! Thanks!

EDIT: Sorry, forgot to mention I'm using XL 2010 on Windows 7.
 
Last edited:

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

C
  • Question
Slow vba
Replies
1
Views
353
Logit
Logit
M
  • Question
run time error '-2147467259 (80004005)' could not topindex property
Replies
0
Views
385
MitchiBoy3
M
S
  • Question
Generate sheets in new workbook instead of existing file
Replies
1
Views
337
Siddhu11011
S
M
  • Solved
VBA Code to Output to .pdf Multiple Charts per Sheet in Multi-sheet Workbook
Replies
2
Views
1K
MedicMutt
M
C
  • Solved
Code to move already selected sheets to other workbook
Replies
5
Views
284
Alex Blakenburg
A

Forum statistics

Threads
1,216,077
Messages
6,128,685
Members
449,463
Latest member
Jojomen56

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