Something like this?
Option Explicit
Sub testme01()
Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim wks As Worksheet
Dim oRow As Long
Dim logWks As Worksheet
Dim myAddr As String
myAddr = "C3"
'change to point at the folder to check
myPath = "c:\my documents\excel\test"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If
Application.ScreenUpdating = False
'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop
Set logWks = Workbooks.Add(1).Worksheets(1)
logWks.Range("a1").Resize(1, 4).Value _
= Array("Workbook", "Worksheet", "Formula", "Value")
oRow = 1
With logWks
If fCtr > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar = "Processing: " & myFiles(fCtr)
Set tempWkbk = Nothing
On Error Resume Next
Set tempWkbk = Workbooks.Open(Filename:=myPath & myFiles(fCtr))
On Error GoTo 0
If tempWkbk Is Nothing Then
MsgBox "Error Opening: " & myFiles(fCtr)
Else
For Each wks In tempWkbk.Worksheets
oRow = oRow + 1
.Cells(oRow, "A").Value = "'" & tempWkbk.Name
.Cells(oRow, "B").Value = "'" & wks.Name
.Cells(oRow, "C").Value _
= "'" & wks.Range(myAddr).Formula
With .Cells(oRow, "D")
.Value = wks.Range(myAddr).Value
.NumberFormat = wks.Range(myAddr).NumberFormat
End With
Next wks
tempWkbk.Close savechanges:=False
End If
Next fCtr
End If
.UsedRange.Columns.AutoFit
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
