Search multiple workbooks (inc sheets) for string then copy and paste to new workbook

Jimothy · Feb 28th 2012

Hi Guys

I have been working on a project for a few months now and have learnt a great deal about VBA in that time. I am stuck though with this one. I currently have a macro that allows me to open multiple workbooks and copy a set table from a set sheet in each workbook and wonder if it might be adapted to work in this way as well?

Basically I need it to search each row on each sheet from multiple workbooks and look at each sheet in the book for a unique reference and then copy the whole row to a new workbook.

For example there are 5 teams each with their own workbook and each sheet as different tasks allocated to each team. The tasks have their own unique numbers starting from "C-1" and up. I would like it to be possible to enter the reference "C-1" and then copy every row that has that reference into a new workbook from every sheet/book. Hope this make sense.

If anyone could help I would greatly appreciate it.

jindon · Feb 29th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

try

Code

Sub test()
Dim myDir As String, fn As String, ws As Worksheet, r As Range
Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
myDir = "c:\test\"   '<- change here
If Dir(myDir, 16) = "" Then
    MsgBox "No such foloder path", 64, myDir
    Exit Sub
End If
myTask = InputBox("Enter Task number")
If myTask = "" Then Exit Sub
x = Columns.Count
fn = Dir(myDir & "*.xls*")
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Do While fn <> ""
    With Workbooks.Open(myDir & fn, 0)
        For Each ws In .Worksheets
            Set r = ws.Cells.Find(myTask, , , 1)
            If Not r Is Nothing Then
                ff = r.Address
                Do
                    n = n + 1
                    temp = r.EntireRow.Value
                    ReDim Preserve temp(1 To 1, 1 To x)
                    ReDim Preserve a(1 To n)
                    a(n) = temp
                    Set r = ws.Cells.FindNext(r)
                Loop While ff <> r.Address
            End If
        Next
        .Close False
    End With
    fn = Dir
Loop
With ThisWorkbook.Sheets(1).Rows(1)
    .CurrentRegion.ClearContents
    If n > 0 Then
        .Resize(n).Value = _
        Application.Transpose(Application.Transpose(a))
    Else
        MsgBox "Not found", , myTask
    End If
End With

Display More

Jimothy · Mar 2nd 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Supurb thank you Jindon thats brilliant. Do you know how I would narrow the range on each sheet down to A12:A65? Also do you think it would be possible to add at the end of each copied row the sheet name and file name it was taken from? Or just copy a cell showing Team Name and Date that day?

Thanks again for this.

jindon · Mar 2nd 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

change to

Code

Sub test()
    Dim myDir As String, fn As String, ws As Worksheet, r As Range
    Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
    myDir = "c:\test\" '<- change here
    If Dir(myDir, 16) = "" Then
        MsgBox "No such foloder path", 64, myDir
        Exit Sub
    End If
    myTask = InputBox("Enter Task number")
    If myTask = "" Then Exit Sub
    x = Columns.Count
    fn = Dir(myDir & "*.xls*")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Do While fn <> ""
        With Workbooks.Open(myDir & fn, 0)
            For Each ws In .Worksheets
                Set r = ws.Range("a12:a65").Find(myTask, , , 1)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        n = n + 1
                        ReDim Preserve a(1 To n)
                        temp = r.EntireRow.Value
                        ReDim Preserve temp(1 To 1, 1 To x)
                        a(n) = temp
                        Set r = ws.Range("a12:a65").FindNext(r)
                    Loop While ff <> r.Address
                    n = n + 1
                    ReDim Preserve a(1 To n)
                    ReDim temp(1 To x)
                    temp(1) = fn
                    temp(2) = ws.Name
                    a(n) = temp
                End If
            Next
            .Close False
        End With
        fn = Dir
    Loop
    With ThisWorkbook.Sheets(1).Rows(1)
        .CurrentRegion.ClearContents
        If n > 0 Then
            .Resize(n).Value = _
            Application.Transpose(Application.Transpose(a))
        Else
            MsgBox "Not found", , myTask
        End If
    End With
End Sub

Display More

Jimothy · Mar 4th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Thanks again Jindon. This is brilliant exactly what I need. I have been playing with the code to see if I could incorporate a multi-select file option instead of a preset directory. I haven't had much luck and I am probably miles off from what I need and probably out of my league at the moment. But here is what I have so far:

Code

Sub test()
Dim myDir As Variant, fn As String, ws As Worksheet, r As Range
Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
Dim SaveDriveDir As String
SaveDriveDir = CurDir


myDir = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
myTask = InputBox("Enter Task number")
If myTask = "" Then Exit Sub
x = Columns.Count
fn = Dir(myDir & "*.xls*")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Do While fn <> ""
With Workbooks.Open(myDir & fn, 0)
For Each ws In .Worksheets
Set r = ws.Range("a12:aH61").Find(myTask, , , 1)
If Not r Is Nothing Then
ff = r.Address
Do
n = n + 1
ReDim Preserve a(1 To n)
temp = r.EntireRow.Value
ReDim Preserve temp(1 To 1, 1 To x)
a(n) = temp
Set r = ws.Range("a12:aH61").FindNext(r)
Loop While ff <> r.Address
n = n + 1
ReDim Preserve a(1 To n)
ReDim temp(1 To x)
temp(1) = fn
temp(2) = ws.Name
a(n) = temp
End If
Next
.Close False
End With
fn = Dir
Loop
With ThisWorkbook.Sheets(1).Rows(1)
.CurrentRegion.ClearContents
If n > 0 Then
.Resize(n).Value = _
Application.Transpose(Application.Transpose(a))
Else
MsgBox "Not found", , myTask
End If
End With
End Sub

Display More

I keep getting Error 13 Type Mismatch with above.

Thanks again really happy with how it all works.

jindon · Mar 4th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

try

Code

Sub test()
    Dim fn, e, ws As Worksheet, r As Range
    Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
    Dim SaveDriveDir As String
    SaveDriveDir = CurDir
     
    fn = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
    MultiSelect:=True)
    If Not IsArray(fn) Then Exit Sub
    myTask = InputBox("Enter Task number")
    If myTask = "" Then Exit Sub
    x = Columns.Count
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each e In fn
        With Workbooks.Open(e, 0)
            For Each ws In .Worksheets
                Set r = ws.Range("a12:aH61").Find(myTask, , , 1)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        n = n + 1
                        ReDim Preserve a(1 To n)
                        temp = r.EntireRow.Value
                        ReDim Preserve temp(1 To 1, 1 To x)
                        a(n) = temp
                        Set r = ws.Range("a12:aH61").FindNext(r)
                    Loop While ff <> r.Address
                    n = n + 1
                    ReDim Preserve a(1 To n)
                    ReDim temp(1 To x)
                    temp(1) = e
                    temp(2) = ws.Name
                    a(n) = temp
                End If
            Next
            .Close False
        End With
    Next
    With ThisWorkbook.Sheets(1).Rows(1)
        .CurrentRegion.ClearContents
        If n > 0 Then
            .Resize(n).Value = _
            Application.Transpose(Application.Transpose(a))
        Else
            MsgBox "Not found", , myTask
        End If
    End With
End Sub

Display More

Jimothy · Mar 4th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Hi Jindon

Thanks again. That covers everything I need now once again thank you. However I do get an error from time to time "Type Mismatch" i'm wondering if this has something to do with the ammount of text in a cell as that seems to trigger the error if there is a lot in the task cell that the ref ties into.
Thanks again.

jindon · Mar 4th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Try change

Code

For Each ws In .Worksheets 
                Set r = ws.Range("a12:aH61").Find(myTask, , , 1) 
                If Not r Is Nothing Then 
                    ff = r.Address 
                    Do 
                        n = n + 1 
                        Redim Preserve a(1 To n) 
                        temp = r.EntireRow.Value 
                        Redim Preserve temp(1 To 1, 1 To x) 
                        a(n) = temp 
                        Set r = ws.Range("a12:aH61").FindNext(r) 
                    Loop While ff <> r.Address 
                    n = n + 1 
                    Redim Preserve a(1 To n) 
                    Redim temp(1 To x) 
                    temp(1) = e 
                    temp(2) = ws.Name 
                    a(n) = temp 
                End If 
            Next

Display More

to

Code

For Each ws In .Worksheets 
                Set r = ws.Range("a12:aH61").Find(myTask, , , 1) 
                If Not r Is Nothing Then 
                    ff = r.Address 
                    Do 
                        n = n + 1 
			ThisWorkbook.Sheets(1).Rows(n).Value = _
			r.EntireRow.Resize( , x).Value
                        Set r = ws.Range("a12:aH61").FindNext(r) 
                    Loop While ff <> r.Address 
                    n = n + 1 
		    ThisWorkbook.Sheets(1).Cells(n, 1).Resize(, 2).Value = _
                    Array(fn, ws.Name)  
                End If 
            Next

Display More

Jimothy · Mar 5th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Hi Jindon

I made the changes you suggested. Unfortunately I now get "Invalid Procedure Call or Argument". Any idea what I did wrong here?

Thanks Again

jindon · Mar 5th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Oops, sorry

Change to

Code

Sub test()
    Dim fn, e, ws As Worksheet, r As Range
    Dim a(), n As Long, myTask As String, ff As String, temp
    Dim SaveDriveDir As String
    SaveDriveDir = CurDir
     
    fn = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
    MultiSelect:=True)
    If Not IsArray(fn) Then Exit Sub
    myTask = InputBox("Enter Task number")
    If myTask = "" Then Exit Sub
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each e In fn
        With Workbooks.Open(e, 0)
            For Each ws In .Worksheets
                Set r = ws.Range("a12:aH61").Find(myTask, , , 1)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        n = n + 1
                        ThisWorkbook.Sheets(1).Rows(n).Resize(, Columns.Count).Value = _
                        r.EntireRow.Value
                        Set r = ws.Range("a12:aH61").FindNext(r)
                    Loop While ff <> r.Address
                    n = n + 1
                    ThisWorkbook.Sheets(1).Cells(n, 1).Resize(, 2).Value = _
                    Array(e, ws.Name)
                End If
            Next
            .Close False
        End With
    Next
End Sub

Display More

Jimothy · Mar 5th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Hi Jindon

Supurb thank you. I had changed the last code "With ThisWorkbook.Sheets(1).Rows(5)" so that I could paste the data rows in. Can't see where I could make this change on the new code you supplied?

Thanks

jindon · Mar 5th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

In that case, insert 2 lines

Code

End With
    ThisWorkbook.Sheets(1).Rows(5).CurrentRegion.ClearContents  '<- from here
    n = 4  ' < - to here
    For Each e In fn

Jimothy · Mar 27th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Hi Jindon

Apologises for delayed response. Just managed to get back round to looking at this after working on the main sheet this file is searching. Seem to have hit a problem though. The Task No is displayed by a formula if data is entered into the any of the columns next to the task. When I try to search I get no results. When I try to search by manually entering a task no into a cell it picks it up no problem? Any idea what I am doing wrong?

Thanks again.

jindon · Mar 28th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

try change

Code

Set r = ws.Range("a12:aH61").Find(myTask, , , 1)

to

Code

Set r = ws.Range("a12:aH61").Find(myTask, , xlValues , 1)

Jimothy · May 11th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Hi Jindon

Apologies for the delay I have been busy at work and haven't had time to look at this again until now. I just tried adding the XLValues as you suggested but it stil won't pick up any values in hidden column. I also tried xlFormulas. The only time it works is when I unhide the column on the main sheet it picks it up?

Not sure what else to try. Any help you can offer would be greatly appreciated.

Thanks

Jimothy · May 11th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Hi Jindon

I have got it working using xlformulas and it does exactly what it is meant to do now :-). Thank you. Is there any way to tell it to ignore when it finds a relevant task number but no outcome has been entered in between columns B and AE? Also I tried to use RESIZE as I only want it to take values from Column A to AE. Keep getting weird results whenever I try this? Is what I am trying possible?

Thanks Again

Jimothy · May 11th 2012

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Code

Sub test()
Dim fn, e, ws As Worksheet, r As Range
Dim a(), n As Long, myTask As String, ff As String, temp
Dim SaveDriveDir As String
SaveDriveDir = CurDir


fn = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If Not IsArray(fn) Then Exit Sub
myTask = InputBox("Enter Task Number")
If myTask = "" Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
ThisWorkbook.Sheets(1).Rows(5).Range("A5:AH18").ClearContents '<- from here
n = 4
For Each e In fn
With Workbooks.Open(e, 0)
For Each ws In .Worksheets
Set r = ws.Range("AI12:AI110").Find(myTask, , xlFormulas, 1)
If Not r Is Nothing Then
ff = r.Address
Do
n = n + 1
ThisWorkbook.Sheets(1).Rows(n).Resize(1, 30).Value = _
r.EntireRow.Value
Set r = ws.Range("AI12:AI110").FindNext(r)
Loop While ff <> r.Address
n = n + 1
ThisWorkbook.Sheets(1).Cells(n, 1).Resize(, 2).Value = _
Array(e, ws.Name)
End If
Next
.Close False
End With
Next
End Sub

Display More

Please see changes I have made to code so far. I seem to have been able to get the resize working as I wanted. I tried some methods of missing out tasks with blank cells between Columns B & AE but haven't been successful.

Thanks again

Color Code · Oct 14th 2015

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

I have workbooks for each month. they all contain a column with date, another with tramline number and another with delay reason. To specify the delay reason the row with the entry is colorcoded red or green.To search for specific tramline number and date i used the code above. Its perfect. But the result however comes back in a new sheet without the color code.
I tried to change the application.transpose command and had a look at the ws.cells.find command together with a IT pro from my company. But no one knows VBA.
Please help.
Thanks

jindon · Oct 14th 2015

Re: Search multiple workbooks (inc sheets) for string then copy and paste to new work

Color Code

Please open a new thread for you own question.

Search multiple workbooks (inc sheets) for string then copy and paste to new workbook

Participate now!

Share