VBA: Search all workbooks in folder for text and copy whole row to new sheet

[anewman5high]

Hello,

I'm trying to put together a VBA button to search all of the workbooks in a specified folder for a user inputted word in any cell (usually column A if that makes it easier). Once found I'd like it to copy the whole row to a new sheet in the Workbook the VBA is run from. Currently I have frankensteined together the below code from Google searches. It lists the Name of the workbook and sheet the text was found in and then the address and contained text of the cell it was found in. I'd like to keep these if possible but then copy the rest of the row from column 5 onwards.

I'm sure I'm doing something very basic wrong but just can't seem to get this bit right! Also happy to throw away all of the below code if something else works better!

Sub SearchFolders()
    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String


    On Error GoTo ErrHandler
    Application.ScreenUpdating = False


    strPath = "C:\Searchfolderhere\"
    strSearch = InputBox("Search Term")


    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "Cell"
        .Cells(lRow, 4) = "Text in Cell"
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)


        strFile = Dir(strPath & "\*.xls*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open _
              (Filename:=strPath & "\" & strFile, _
              UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)


            For Each wks In wbk.Worksheets
                Set rFound = wks.UsedRange.Find(strSearch)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                        .Cells(lRow, 1) = wbk.Name
                        .Cells(lRow, 2) = wks.Name
                        .Cells(lRow, 3) = rFound.Address
                        .Cells(lRow, 4) = rFound.Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            Next


            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit
    End With
    MsgBox "Done"


ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub


ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Thanks in advance for any help, apologies if I've explained myself badly!

Alan

 

[mumps]

Untested...try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim wOut As Worksheet
    Dim wks As Worksheet
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim strSearch As String
    Const strPath As String = "C:\Searchfolderhere\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xls*")
    strSearch = InputBox("Please enter the Search Term.")
    Set wOut = Worksheets.Add
    wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each wks In .Sheets
                Set rFound = wks.Range("A:A").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                    Do
                        wOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbSource.Name
                        wOut.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = wks.Name
                        wOut.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rFound.Address
                        wOut.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = rFound.Value
                        wks.Range(Cells(rFound.Row, 5), Cells(Cells(rFound.Row, Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
                        Set rFound = wks.Range("A:A").FindNext(rFound)
                    Loop While rFound.Address <> strFirstAddress
                    sAddr = ""
                End If
            Next wks
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[anewman5high]

Hi mumps,

Thanks for your reply.

I've tested it and had to make a small change as I was getting a "range of object _worksheet failed" error.

I made a small change to line 30 which gets past the debug error: "wks.Range(wks.Cells(rFound.Row, 1), wks.Cells(wks.Cells(rFound.Row, Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)"

However while it does copy the information, it is copying all rows instead of just the rFound row. Is there a way to fix this? I've tried tweaking it but all I seem to get is errors about the copy paste size being different!

Thanks,
Alan

 

[mumps]

If there are multiple occurrences of the search string (strSearch) in column A of the source sheets, then all the rows containing the string will be copied. If there are multiple occurrences and you only want the first one copied, then the code has to be modified. Please clarify.

 

[anewman5high]

I'd like it to copy all rows where the search string appears in Column A but at the moment it seems to be copying all rows including ones where the string doesn't appears in column A. It seems to be copying the entire sheet for each time it finds the string in column A instead of just the row.

 

[mumps]

I can't seem to figure out how it could be copying the entire sheet since the range uses rFound.row as the row number for the range to copy. Try stepping through the macro line by line using the F8 key and look at your sheet after each line is executed to see what is happening.

 

[anewman5high]

That's the problem I'm having, to my untrained eye it looks like it should work. When I step through the code everything else works perfectly until I get to line 30 and it pulls through everything in the sheet. COuld it be the changes I made to line 30 to get around the error that are causing the problem?

 

[anewman5high]

OK so I was slightly wrong, it isn't copying the entire sheet, it's copying everything from above the first row it finds the search string in.

 

[Fluff]

Add the line in red to your code

For Each wks In .Sheets
                Set rFound = wks.Range("A:A").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                   [COLOR=#ff0000] MsgBox strFirstAddress & vbLf & rFound.Address[/COLOR]
                    Do
                        wOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbSource.Name

What are the 2 addresses that appear in the message box?

 

[mumps]

Try this line of code:

wks.Range(wks.Cells(rFound.Row, 1), wks.Cells(rFound.Row, wks.Cells(rFound.Row, wks.Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)