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