VBA - Search all workbooks in a folder for text criteria and copy row to new sheet

[APM]

Hello,

I am trying to put together a VBA code to search all of the workbooks in a specific folder (combine) based on user text criteria from an input box (Net Income). When the code finds it, I would like to copy the whole row into a new sheet.
My current issue is that I cannot figure out how to search all columns of all workbooks, other than just column A, and return the row data as a block where I have the name of the Workbook, name of the Worksheet, Cell position, Text in Cell (user text criteria), then the row data (see screenshots attached - Code expectation). Basically, if the text criteria entered is not in column A, the code does not copy the row based on the criteria's position or sometimes does it but leave spaces between the Text in Cell and where the row data should be (see screenshot).
I am sure there is a better solution or a way to fix this code for this code. In advance, thanks for any help and for your time. It would be a great learning experience. Feel free to reach out if I haven't explained myself well. Thanks!

>>> use code - tags <<<

Dim strFirstAddress As String
    Dim strSearch As String
    Const strPath As String = "/Users/xxx/Desktop/combine/"
    ChDir strPath
    strExtension = Dir("*.xlsx*") 'File type can be modified to fit csv files
    strSearch = InputBox("Please enter the Search Keyword.") 'Search Keyword all reports
    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(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)
                        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

 

[RDAngelo]

Possibly...

    Dim strFirstAddress As String
    Dim strSearch As String
    Dim strExtension As String
    Dim wOut As Worksheet
    Dim wkbSource As Workbook
    Dim wks As Worksheet
    Dim rFound As Range
    Dim lRow As Long
    Const strPATH As String = "/Users/xxx/Desktop/combine/"

    ChDir strPATH
    strExtension = Dir("*.xlsx*")                 'File type can be modified to fit csv files
    strSearch = InputBox("Please enter the Search Keyword.") 'Search Keyword all reports
    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.UsedRange.Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                    Do
                        lRow = wOut.Cells(Rows.Count, 1).End(xlUp).Row + 1
                        wOut.Cells(lRow, 1) = wkbSource.Name
                        wOut.Cells(lRow, 2) = wks.Name
                        wOut.Cells(lRow, 3) = rFound.Address
                        wOut.Cells(lRow, 4) = rFound.Value
                        wOut.Cells(lRow, 5) = wks.Cells(rFound.Row, Columns.Count).End(xlToLeft).Value
                        Set rFound = wks.UsedRange.FindNext(rFound)
                    Loop While rFound.Address <> strFirstAddress
'                    sAddr = ""
                End If
            Next wks
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True

 

[APM]

Thank you! it works perfectly!

 

[RDAngelo]

You are welcome. Glad I could help!

 

[hippyrider]

Hi experts

I have been trying to modify the below to search all workbooks in a specific folder but restrict the search to the IndexPage sheet not all the sheets. Any ideas my "If wks.Name = "IndexPage" Then" does not speed it up at all.


Code
>>> use - code tags <<<

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then

    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

    'Change as desired
    strPath = "D:\shops\Stats"
    strSearch = Range("A1").Value
   
    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Link"
        .Cells(lRow, 2) = "Workbook"
        .Cells(lRow, 3) = "Worksheet"
        .Cells(lRow, 4) = "Cell"
        .Cells(lRow, 5) = "Text in Cell"
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)

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

        For Each wks In wbk.Worksheets
            If wks.Name = "IndexPage" Then
                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) = "=HYPERLINK(""[D:\shops\Stats\" & wbk.Name & "]ChartView!A1"",""CLICK HERE"")"
                        .Cells(lRow, 2) = wbk.Name
                        .Cells(lRow, 3) = wks.Name
                        .Cells(lRow, 4) = rFound.Address
                        .Cells(lRow, 5) = rFound.Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            End If
        Next

            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:E").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 If
End Sub

 

[vletm]

hippyrider​

This is over two years and someone else's thread.
You should open a new own thread based Your challenge.
... as You've read from Forum Rules
... ... New Users - Please Start Here
This thread is closed now.