Search multiple workbooks in a folder and subfolders for a specific string

[jskasango]

I need a VBA code to let me browse to a folder and Search for a specific string in multiple workbooks ((*.xl*) Sheet.Results)) in the folder and subfolders . If the specified string is found the code should copy the entire row into a new "Found" workbook including the headers from the first "Hit" only and any "new" headers in subsequent "finds" should be appended to the right of the "Found".
Any assistance will be highly appreciated. THANK YOU VERY MUCH IN ADVANCE.

 

[jskasango]

Clarification: The headers are in Row 1 and abbreviated in Row 2 and the range to search starts at Row 25. I am doing this manually and it is taking light years to achieve.

 

[NdNoviceHlp]

You need a bit more clarification. Search all sheets in each wb? Look in header to match data in row 25 and down for each column? Where exactly do you want the output? Here's a start. HTH. Dave

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Application.ScreenUpdating = False
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
'do stuff here


Workbooks(FileNm.Name).Close savechanges:=False
End If
Next FileNm
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

 

[jskasango]

Clarification:
1. Search in worksheet "Results" only
2. Header in Row1to match data in row 25 and down for each column
3. Output to New Workbook named same as the folder I selected.
Thanks @NdNoviceHlp . Trying the Start. Kasango

 

[jskasango]

Clarification2, I would appreciate if the search criteria could use "Containing...".
Thanks- Kasango

 

[jskasango]

Clarification2, I would appreciate if the search criteria could use "Containing...".
Thanks- Kasango

If it’s logical and not too late “and or Beginning with…”
Thanks-Kasango.

 

[NdNoviceHlp]

Hi Kasango. I don't really understand a few things. Do you want to search the column for the header contents or search the column for "Containing" and/or "Beginning with"? Do you want to create a new wb with the same name as the folder and then copy each found row to sheet1 from row 1 down? Here's what we've got so far...

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet
Dim LastRow As Double, LastCol As Integer, Cnt As Integer, Cnt2 As Double
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Application.ScreenUpdating = False
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Results") Then
With Workbooks(FileNm.Name).Sheets(Sht.Name)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Cnt = 1 To LastCol 'cols
LastRow = .Cells(.Rows.Count, Cnt).End(xlUp).Row
For Cnt2 = 25 To LastRow 'rows
'search if column contains key words
'If InStr(.Cells(Cnt2, cnt), "Containing") Or _
      InStr(.Cells(Cnt2, cnt), "Beginning with") Then
'search header with column for key word
If LCase(.Cells(Cnt2, Cnt)) = LCase(.Cells(1, Cnt)) Then
'***************************
'transfer stuff here

'***************************
GoTo Below
End If 'search
Next Cnt2
Next Cnt
End With
End If 'sht name
Next Sht
Below:
Workbooks(FileNm.Name).Close savechanges:=False
End If 'file name
Next FileNm
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

Dave

 

[jskasango]

Hi Kasango. I don't really understand a few things. Do you want to search the column for the header contents or search the column for "Containing" and/or "Beginning with"? Do you want to create a new wb with the same name as the folder and then copy each found row to sheet1 from row 1 down? Here's what we've got so far...

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet
Dim LastRow As Double, LastCol As Integer, Cnt As Integer, Cnt2 As Double
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Application.ScreenUpdating = False
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Results") Then
With Workbooks(FileNm.Name).Sheets(Sht.Name)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Cnt = 1 To LastCol 'cols
LastRow = .Cells(.Rows.Count, Cnt).End(xlUp).Row
For Cnt2 = 25 To LastRow 'rows
'search if column contains key words
'If InStr(.Cells(Cnt2, cnt), "Containing") Or _
      InStr(.Cells(Cnt2, cnt), "Beginning with") Then
'search header with column for key word
If LCase(.Cells(Cnt2, Cnt)) = LCase(.Cells(1, Cnt)) Then
'***************************
'transfer stuff here

'***************************
GoTo Below
End If 'search
Next Cnt2
Next Cnt
End With
End If 'sht name
Next Sht
Below:
Workbooks(FileNm.Name).Close savechanges:=False
End If 'file name
Next FileNm
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

Dave

Hi Kasango. I don't really understand a few things. Do you want to search the column for the header contents or search the column for "Containing" and/or "Beginning with"? Do you want to create a new wb with the same name as the folder and then copy each found row to sheet1 from row 1 down? Here's what we've got so far...

Sub test()
Dim FSO As Object, FolDir As Object, FileNm As Object
Dim TargetFolder As FileDialog, Sht As Worksheet
Dim LastRow As Double, LastCol As Integer, Cnt As Integer, Cnt2 As Double
Set TargetFolder = Application.FileDialog(msoFileDialogFolderPicker)
With TargetFolder
.AllowMultiSelect = False
.Title = "Select Folder:"
.Show
End With
If TargetFolder.SelectedItems.Count = 0 Then
MsgBox "PICK A Folder!"
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
Set FolDir = FSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
Application.ScreenUpdating = False
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".xls" & "*" Then
Workbooks.Open Filename:=FileNm
For Each Sht In Workbooks(FileNm.Name).Worksheets
If LCase(Sht.Name) = LCase("Results") Then
With Workbooks(FileNm.Name).Sheets(Sht.Name)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Cnt = 1 To LastCol 'cols
LastRow = .Cells(.Rows.Count, Cnt).End(xlUp).Row
For Cnt2 = 25 To LastRow 'rows
'search if column contains key words
'If InStr(.Cells(Cnt2, cnt), "Containing") Or _
      InStr(.Cells(Cnt2, cnt), "Beginning with") Then
'search header with column for key word
If LCase(.Cells(Cnt2, Cnt)) = LCase(.Cells(1, Cnt)) Then
'***************************
'transfer stuff here

'***************************
GoTo Below
End If 'search
Next Cnt2
Next Cnt
End With
End If 'sht name
Next Sht
Below:
Workbooks(FileNm.Name).Close savechanges:=False
End If 'file name
Next FileNm
Application.ScreenUpdating = True
Set FolDir = Nothing
Set FSO = Nothing
End Sub

Dave

David- Thanks for the follow up.
The code should pick the headers only once from row 1 of the first sheet containing a “find”.
The search or data starts at row 25. At each find, only entire row should be copied to the output which should by a WB named same as the folder that I chose for the search. Thereafter, all other finds (entire row) should be appended to the sheet which already has headers. In case of a new find with a new header, please let it go to the rightmost of the old headers.
Thanks- Kasango.

 

[NdNoviceHlp]

The new wb has headers? It sounds like there can be more than 1 find per column? U didn't clarify whether the search is for the header and what "containing" and "Beginning with" has to do with the search? Dave

 

[jskasango]

David- Thanks for the follow up.
The code should pick the headers only once from row 1 of the first sheet containing a “find”.
The search or data starts at row 25. At each find, only entire row should be copied to the output which should by a WB named same as the folder that I chose for the search. Thereafter, all other finds (entire row) should be appended to the sheet which already has headers. In case of a new find with a new header, please let it go to the rightmost of the old headers.
Thanks- Kasango.

All sheets have the same structure, save for new header popping up in some sheet.