Search multiple worksheets for search term and paste results in a new workbook

[Andy15]

Hi Guys,

I am looking for a little bit of help. I have managed to write some code which enables me to search for some text via an input box. I can then copy the relevant column and also copy columns A and B on the same worksheet. I then paste this information into a new worksheet named "SEARCH". I then loop through all of the additional worksheets and paste any further results to the right of any previously pasted columns.

All of the above is working fine.

What I would like to do is paste the information above into a new workbook rather than a sheet named "SEARCH"in the existing workbook.

Please find my code below

Option Explicit
Option Compare Text '< ignore case
'
Sub Searchcolumns()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
'

With Application
.ScreenUpdating = False
.EnableEvents = False
End With


WhatFor = InputBox("What are you looking for?", "Search Criteria")
If WhatFor = Empty Then Exit Sub
'
For Each Sheet In Sheets
If Sheet.Name <> "SEARCH" Then
With Sheet.Rows(2)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do

Sheet.Range("A1").EntireColumn.Copy Destination:=Sheets("SEARCH").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
Sheet.Range("B1").EntireColumn.Copy Destination:=Sheets("SEARCH").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

Cell.EntireColumn.Copy Destination:=Sheets("SEARCH").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
'
Set Cell = Nothing

'AutoFit All Columns on Worksheet
ThisWorkbook.Worksheets("Search").Cells.EntireColumn.AutoFit

End Sub



I have tried the following bit of code

Dim wkb As Workbook
Set wkb = Workbooks.Add ' Will add new workbook

but what that does is create a new workbook for every occurrence of the search term.

Many thanks

 

[dmt32]

Hi,
welcome to forum

Untested but see if this update to your code does what you want:

Sub Searchcolumns()
'
    Dim FirstAddress As String, WhatFor As String
    Dim Cell As Range, Sheet As Worksheet
    Dim wkb As Workbook


    
    Do
        WhatFor = InputBox("What are you looking for?", "Search Criteria")
        If StrPtr(WhatFor) = 0 Then Exit Sub
    Loop Until Len(WhatFor) > 0
    
    Application.ScreenUpdating = False
    
'Will add new workbook
    Set wkb = Workbooks.Add(1)
'
    For Each Sheet In Worksheets
        If Sheet.Name <> "SEARCH" Then
            With Sheet.Rows(2)
                Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
                If Not Cell Is Nothing Then
                    FirstAddress = Cell.Address
                    Do
                        
                        Sheet.Range("A1").EntireColumn.Copy _
                        Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
                        Sheet.Range("B1").EntireColumn.Copy _
                        Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
                        
                        Cell.EntireColumn.Copy _
                        Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
                        
                        Set Cell = .FindNext(Cell)
                        
                    Loop Until Cell.Address = FirstAddress
                End If
            End With
        End If
        Set Cell = Nothing
    Next Sheet
'
        
        
'AutoFit All Columns on Worksheet
    wkb.Worksheets(1).Cells.EntireColumn.AutoFit
        
    Application.ScreenUpdating = True


        
End Sub

Hope Helpful

Dave

 

[Andy15]

Hi Dave,

Thanks for your reply. I have tried the code, it opens a new workbook but does not paste anything into it.

Thanks
Andy

 

[dmt32]

Hi Dave,

Thanks for your reply. I have tried the code, it opens a new workbook but does not paste anything into it.

Thanks
Andy

Change this line

For Each Sheet In Worksheets

to this

For Each Sheet In ThisWorkbook.Worksheets

Dave

 

[Andy15]

Worked perfectly

Top man

Many thanks

 

[dmt32]

Worked perfectly

Top man

Many thanks

Always the way when you type something out without testing - miss bit in the code!

Glad update finally worked & appreciate feedback

Dave

 

[Andy15]

Hi Guys,

I have the following code that is working great with the help of Dave and it copies the relevant data to a new workbook.

I wonder if somebody can help modify the code to have a pop up asking for the name of an existing workbook for the data to be copied to.

Also is there a way to also have a pop up to select s specific sheet within the workbook rather than sheet 1

[/COLOR]
Option Explicit Option Compare Text '< ignore case
 '
Sub Searchcolumns()
'
    Dim FirstAddress As String, WhatFor As String
    Dim Cell As Range, Sheet As Worksheet
    Dim wkb As Workbook




    
    Do
        WhatFor = InputBox("What are you looking for?", "Search Criteria")
        If StrPtr(WhatFor) = 0 Then Exit Sub
    Loop Until Len(WhatFor) > 0
    
    Application.ScreenUpdating = False
    
'Will add new workbook
    Set wkb = Workbooks.Add(1)
'
    For Each Sheet In ThisWorkbook.Worksheets
        'If Sheet.Name <> "SEARCH" Then  'this can be deleted when copying to a new workbook
            With Sheet.Rows(2)
                Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
                If Not Cell Is Nothing Then
                    FirstAddress = Cell.Address
                    Do
                        
                        Sheet.Range("A1").EntireColumn.Copy _
                        Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
                        Sheet.Range("B1").EntireColumn.Copy _
                        Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
                        
                        Cell.EntireColumn.Copy _
                        Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
                        
                        Set Cell = .FindNext(Cell)
                        
                    Loop Until Cell.Address = FirstAddress
                End If
            End With
        'End If     'this can be deleted when copying to a new workbook
        Set Cell = Nothing
    Next Sheet
'
        
        
'AutoFit All Columns on Worksheet
    wkb.Worksheets(1).Cells.EntireColumn.AutoFit
        
    Application.ScreenUpdating = True




        

End Sub
[COLOR=#333333]

Thanks

 

[Andy15]

Hi Dave,

Sorry to ask for some help but I have tried making changes to the code you sorted but I don't seem to be able to get my head around the errors I keep getting.

At the moment the code is copied into a new workbook called sheet1 and to the worksheet sheet1 within that workbook.

Once I am up and running I will want to paste the info into existing workbooks and existing sheets in the respective workbooks.

Is there a way to use an input box to select the workbook (workbook can exist beforehand) and then an input box to select the sheet name within the workbook. (sheet can exist beforehand)

Hoping you can assist

Thanks Andy