Sub SearchFolders() Dim Fso As Object
Dim Fld As Object
Dim RngSearch As Range
Dim StrPath As String
Dim StrFile As String
Dim Out As Worksheet
Dim Wb As Workbook
Dim Wk As Worksheet
Dim Row As Long
Dim Found As Range
Dim Column As Range
Dim StrAddress As String
Dim FileDialog As FileDialog
Dim Update As Boolean
Dim Count As Long
Dim sName As Variant
On Error GoTo ErrHandler
Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
FileDialog.AllowMultiSelect = False
FileDialog.Title = "Select a forlder"
If FileDialog.Show = -1 Then
StrPath = FileDialog.SelectedItems(1)
End If
If StrPath = "" Then Exit Sub
Set RngSearch = ActiveWorkbook.Worksheets("Search").Range("B2:B2")
Update = Application.ScreenUpdating
Application.ScreenUpdating = False
Set Out = Worksheets.Add
ActiveSheet.Name = Replace(Format(Now, "yyyy.mm.dd hh:mm:ss"), ":", ".")
Row = 1
With Out
.Cells(Row, 1) = "Workbook"
.Cells(Row, 2) = "Worksheet"
.Cells(Row, 3) = "Cell"
.Cells(Row, 4) = "Text in Cell"
.Cells(Row, 5) = "Company Name"
.Cells(Row, 6) = "Last Name"
.Cells(Row, 7) = "First Name"
.Cells(Row, 8) = "SSN"
.Cells(Row, 9) = "Date of Birth"
.Cells(Row, 10) = "Date of Hire"
.Cells(Row, 11) = "QLE Date"
.Cells(Row, 12) = "Product Type"
.Cells(Row, 13) = "Coverage Effective Date"
.Cells(Row, 14) = "SP Coverage Effective Date"
.Cells(Row, 15) = "CH Coverage Effective Date"
.Cells(Row, 16) = "Coverage Tier"
.Cells(Row, 17) = "EE CI Approved Coverage Amount"
.Cells(Row, 18) = "SP CI Approved Coverage Amount"
.Cells(Row, 19) = "CH CI Approved Coverage Amount"
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fld = Fso.GetFolder(StrPath)
StrFile = Dir(StrPath & "\*.csv*")
Do While StrFile <> ""
Set Wb = Workbooks.Open(Filename:=StrPath & "\" & StrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each Wk In Wb.Worksheets
Set Found = Wk.UsedRange.Find(RngSearch)
Set Column = Wk.UsedRange.Find(RngSearch)
If Not Found Is Nothing Then
StrAddress = Found.Address
End If
Do
If Found Is Nothing Then
Exit Do
Else
Count = Count + 1
Row = Row + 1
.Cells(Row, 1) = Wb.Name
.Cells(Row, 2) = Wk.Name
.Cells(Row, 3) = Found.Address
.Cells(Row, 4) = Found.Value
.[COLOR=#ff0000]Cells(1, Found.Column) = Cells(1, Found.Column).Value [/COLOR][COLOR=#00ff00]' Code you suggested pulls back the header name which I am handling above. What I need is the value from the cell in that column[/COLOR][COLOR=#ff0000][/COLOR]
.Cells(Row, 6) = Found.Offset(0, -5).Value
.Cells(Row, 7) = Found.Offset(0, -6).Value
.Cells(Row, 8) = Found.Offset(0, 0).Value
.Cells(Row, 9) = Found.Offset(0, 2).Value
.Cells(Row, 10) = Found.Offset(0, 3).Value
.Cells(Row, 11) = Found.Offset(0, 12).Value
.Cells(Row, 12) = Found.Offset(0, 9).Value
.Cells(Row, 13) = Found.Offset(0, 11).Value
.Cells(Row, 14) = Found.Offset(0, 17).Value
.Cells(Row, 15) = Found.Offset(0, 19).Value
.Cells(Row, 16) = Found.Offset(0, 14).Value
.Cells(Row, 17) = Found.Offset(0, 15).Value
.Cells(Row, 18) = Found.Offset(0, 16).Value
.Cells(Row, 19) = Found.Offset(0, 18).Value
End If
Set Found = Wk.Cells.FindNext(After:=Found)
Loop While StrAddress <> Found.Address
Next
Wb.Close (False)
StrFile = Dir
Loop
.Columns("A:Z").EntireColumn.AutoFit
End With
MsgBox Count & "cells have been found"
ExitHandler:
Set Out = Nothing
Set Wk = Nothing
Set Wb = Nothing
Set Fld = Nothing
Set Fso = Nothing
Application.ScreenUpdating = Update
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
