Are the formulas you wish to compare in the same sheet
name and cell reference in all instances ?
If they are, then there is a fantastic macro that can look
through closed workbooks and extract the data into a
spreadsheet - I got it from John Walkembach's website (J-
walk.com).
I find it invaluable, and have found that it can be
enhanced to include the workbook name as well.
Code is shown below:
Sub CWRIR(fPath As String, fName As String, sName As
String, _
rng As String, destRngUpperLeftCell As String)
Dim sRow As Integer
Dim sColumn As Integer
Dim sRows As Integer
Dim sColumns As Integer
Dim vrow As Integer
Dim vcol As Integer
Dim fpStr As String
Dim cArr()
On Error GoTo NoArr
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Dir(fPath & fName) = "" Then
CWA = CVErr(xlErrValue)
Exit Sub
End If
sRow = Range(rng).Row
sColumn = Range(rng).Column
sRows = Range(rng).Rows.Count
sColumns = Range(rng).Columns.Count
ReDim cArr(sRows, sColumns)
Set destrange = ActiveSheet.Range(destRngUpperLeftCell)
For vrow = 1 To sRows
For vcol = 2 To sColumns + 1
fpStr = "'" & fPath & "[" & fName & "]" & sName & "'!"
& _
"r" & sRow + vrow - 1 & "c" & sColumn + vcol - 2
destrange.Offset(vrow - 1, vcol - 1) =
ExecuteExcel4Macro(fpStr)
Next
Next
NoArr:
End Sub
Sub qaq()
Dim wbName As String, wbList() As String, wbCount As
Integer
Dim f As Integer, Dirme As String, a As String, c As
String, e As String
Dim x As Integer, Sheetme As String, Rangeme As String
Dim DestSheet As String, Destme As String
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' check if you wish to carry on
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
msg = "If you are not pointed to the correct
directory, then select NO."
msg = msg & " - Do you want to continue ? "
DialogStyle = vbYesNo + vbDefaultButton2
Title = "Get data from closed workbooks - please
select choice"
response = MsgBox(msg, DialogStyle, Title)
If response = vbNo Then
MsgBox "You decided not to proceed."
Exit Sub
Else
' get the directory
Dirme = Application.InputBox(prompt:="Please enter the
Directory and path e.g. c:\aeh\ ", _
Title:="Please enter Path and Directory of file
location", Default:="", Type:=2)
' get the sheet name
Sheetme = Application.InputBox(prompt:="Please enter
the name of the worksheet where the data is held e.g.
Sheet1", _
Title:="Please enter the sheet name", Default:="",
Type:=2)
' get the range
Rangeme = Application.InputBox(prompt:="Please enter
the Range of cells to pick up data e.g. A1:A4 ", _
Title:="Please enter range of cells to pick up
data", Default:="", Type:=2)
' get the destination range
Destme = Application.InputBox(prompt:="Please enter
the destination cell e.g. a1", _
Title:="Please enter destination cell",
Default:="", Type:=2)
try2:
' get the destination sheet
DestSheet = Application.InputBox(prompt:="Please enter
the destination Sheet e.g. Sheet2", _
Title:="Please enter destination sheet",
Default:="", Type:=2)
If DestSheet = "Sheet1" Or DestSheet = "sheet1" Then
MsgBox "You are not allowed to use Sheet1"
Application.StatusBar = False
GoTo try2
Else
End If
Application.StatusBar = "Running data retrieval process -
please be patient"
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' create list of workbooks in foldername
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wbCount = 0
wbName = Dir("*.xls")
While wbName <> ""
' MsgBox wbName 'display found workbook
wbCount = wbCount + 1
ReDim Preserve wbList(1 To wbCount)
wbList(wbCount) = wbName
wbName = Dir()
Wend
If wbCount = 0 Then GoTo ErrorOne
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' run required macros against each workbook
' Screen updating, messages & calc turned off at start
of each workbook,
' and back on at finish, prior to saving file
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
x = 0
For f = 1 To wbCount
a = wbList(f)
x = x + 1
Application.StatusBar = "Accessed " & f & " of " & wbCount
& " workbooks so far"
' need to go through this process to make it dynamic
Sheets(DestSheet).Select
Range(Destme).Select
e = Range(Destme).Offset(x, 0).Address(False, False)
Range(Destme).Offset(x, 0).Value = a
CWRIR Dirme, a, Sheetme, Rangeme, e
Next f
Application.StatusBar = False
Sheets("Sheet1").Select
Range("b1").Select
ActiveCell.Value = Now()
Range("b2").Select
ActiveCell.Value = Now()
Exit Sub
ErrorOne:
MsgBox "The path or directory " & Dirme & " does not exist"
Application.StatusBar = False
Exit Sub
End Sub
HTH
Alan
