Does this mean that there is a maximum of a single match in that column?
If yes, then this worked ok for me.
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub testme01()
Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim TempWkbk As Workbook
Dim wks As Worksheet
Dim DestCell As Range
Dim res As Variant
Dim StringToLookFor As String
StringToLookFor = InputBox(prompt:="what to look for:" & vbLf & _
"test" & vbLf & "*test*", _
Title:="surround with *'s if other stuff in the cell")
If Trim(StringToLookFor) = "" Then
Exit Sub
End If
myPath = GetDirectory("Select a Folder")
If myPath = "" Then Exit Sub
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If
Set DestCell = Workbooks.Add(1).Worksheets(1).Range("a1")
DestCell.Resize(1, 5).Value _
= Array("Workbook Name", "Worksheet Name", "Address", _
"Col A Value", "Col B Value")
Application.ScreenUpdating = False
'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop
If fCtr > 0 Then
For fCtr = LBound(myNames) To UBound(myNames)
If LCase(myNames(fCtr)) = LCase(ThisWorkbook.Name) Then
'do nothing, skip this file
Else
Application.StatusBar _
= "Processing: " & myNames(fCtr) & " at: " & Now
Set TempWkbk = Workbooks.Open(Filename:=myPath _
& myNames(fCtr), ReadOnly:=True)
For Each wks In TempWkbk.Worksheets
res = Application.Match(StringToLookFor, _
wks.Range("a:a"), 0)
If IsNumeric(res) Then
'found it
Set DestCell = DestCell.Offset(1)
With DestCell
.Value = TempWkbk.FullName
.Offset(0, 1).Value = "'" & wks.Name
.Offset(0, 2).Value _
= wks.Range("a:a")(res).Address(0, 0)
.Offset(0, 3).Value = wks.Range("a:a")(res).Value
.Offset(0, 4).Value _
= wks.Range("a:a")(res).Offset(0, 1).Value
End With
End If
Next wks
TempWkbk.Close savechanges:=False
End If
Next fCtr
End If
DestCell.Parent.UsedRange.Columns.AutoFit
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
The first few routines let you select a folder that contains all the files--if
the files are all over the place, copy them to a single file.
That code came from John Walkenbach:
http://j-walk.com/ss/excel/tips/tip29.htm
If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm