Code to Copy Data from One Spreadsheet To Another
 

Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

WOW! It seems like I want to use the second example as it ads row by row
instead of column by column but am I understanding it correctly that that
macro adds a second worksheet to each selected workbook or is it that it adds
a second worksheet to the destination workbook? That part is confusing me,
sorry.

Thank You Soooo Much!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

Hi Again,

I copied the macro and made the recommended changes and now when I run the
macro it crashes Excel and I get an Automation Error.

This is exactly what I have in the Sheet2 Macro page...


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("H9,H11,H13") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Did I do something wrong?

Thanks Very Much Again. I Sooo Appreciate this!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

Add the code in a normal module Rob

Alt F11
Insert Module




--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi Again,

I copied the macro and made the recommended changes and now when I run the
macro it crashes Excel and I get an Automation Error.

This is exactly what I have in the Sheet2 Macro page...


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("H9,H11,H13") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Did I do something wrong?

Thanks Very Much Again. I Sooo Appreciate this!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

Both use one row for each file Rob


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
WOW! It seems like I want to use the second example as it ads row by row
instead of column by column but am I understanding it correctly that that
macro adds a second worksheet to each selected workbook or is it that it adds
a second worksheet to the destination workbook? That part is confusing me,
sorry.

Thank You Soooo Much!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

Thanks Again... I'm still getting the error though. Does it matter that the
workbooks that I'm trying to get the data from have macros in them and that I
have my macro security options to medium?

"Ron de Bruin" wrote:

Add the code in a normal module Rob

Alt F11
Insert Module




--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi Again,

I copied the macro and made the recommended changes and now when I run the
macro it crashes Excel and I get an Automation Error.

This is exactly what I have in the Sheet2 Macro page...


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("H9,H11,H13") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Did I do something wrong?

Thanks Very Much Again. I Sooo Appreciate this!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

I think I figured it out. It seems that either the full path name or the
number of subfolders that is being traversed makes a difference. Isn't there
a character limit that a cell formula can have? Anyway, I moved all the
spreadsheets to a single folder on the root c: drive and it works absolutely
perfectly.

Does this mean anything and is there a way to fix this?

"Rob" wrote:

Thanks Again... I'm still getting the error though. Does it matter that the
workbooks that I'm trying to get the data from have macros in them and that I
have my macro security options to medium?

"Ron de Bruin" wrote:

Add the code in a normal module Rob

Alt F11
Insert Module




--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi Again,

I copied the macro and made the recommended changes and now when I run the
macro it crashes Excel and I get an Automation Error.

This is exactly what I have in the Sheet2 Macro page...


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("H9,H11,H13") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Did I do something wrong?

Thanks Very Much Again. I Sooo Appreciate this!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

Rob

The limit is probably 255 characters in the path name.

That limit has been around for a few versions of Windows.


Gord Dibben MS Excel MVP

On Fri, 8 Jun 2007 14:32:01 -0700, Rob wrote:

I think I figured it out. It seems that either the full path name or the
number of subfolders that is being traversed makes a difference. Isn't there
a character limit that a cell formula can have? Anyway, I moved all the
spreadsheets to a single folder on the root c: drive and it works absolutely
perfectly.

Does this mean anything and is there a way to fix this?

"Rob" wrote:

Thanks Again... I'm still getting the error though. Does it matter that the
workbooks that I'm trying to get the data from have macros in them and that I
have my macro security options to medium?

"Ron de Bruin" wrote:

Add the code in a normal module Rob

Alt F11
Insert Module




--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi Again,

I copied the macro and made the recommended changes and now when I run the
macro it crashes Excel and I get an Automation Error.

This is exactly what I have in the Sheet2 Macro page...


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("H9,H11,H13") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Did I do something wrong?

Thanks Very Much Again. I Sooo Appreciate this!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob

Code to Copy Data from One Spreadsheet To Another
 

I will add a note about that limit on the site Gord

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Gord Dibben" <gorddibbATshawDOTca wrote in message ...
Rob

The limit is probably 255 characters in the path name.

That limit has been around for a few versions of Windows.


Gord Dibben MS Excel MVP

On Fri, 8 Jun 2007 14:32:01 -0700, Rob wrote:

I think I figured it out. It seems that either the full path name or the
number of subfolders that is being traversed makes a difference. Isn't there
a character limit that a cell formula can have? Anyway, I moved all the
spreadsheets to a single folder on the root c: drive and it works absolutely
perfectly.

Does this mean anything and is there a way to fix this?

"Rob" wrote:

Thanks Again... I'm still getting the error though. Does it matter that the
workbooks that I'm trying to get the data from have macros in them and that I
have my macro security options to medium?

"Ron de Bruin" wrote:

Add the code in a normal module Rob

Alt F11
Insert Module




--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi Again,

I copied the macro and made the recommended changes and now when I run the
macro it crashes Excel and I get an Automation Error.

This is exactly what I have in the Sheet2 Macro page...


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("H9,H11,H13") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr &
myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Did I do something wrong?

Thanks Very Much Again. I Sooo Appreciate this!
Rob


"Ron de Bruin" wrote:

You can create links to all workbooks to the cells with this macro
http://www.rondebruin.nl/summary2.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Rob" wrote in message ...
Hi,

I was wondering if it is possible to copy the values of the same specific
cells within multiple spreadsheets and place/copy that into a single seperate
spreadsheet?

Basically I'm going to have hundreds of spreadsheets that contain all sorts
of data but I only need to capture the values within three specific cells -
Workbook(Collection00001) thru (Collection99999) - Sheet1 - Cells(H9, H11 &
H13) and then I want to place those values into a single spreadsheet -
Workbook(Captures) - Sheet1 - Cells(B3, C3 & D3) then (B4, C4 & D4) then (B5,
C5 &D5) etc.

Is there a way of doing this or am I going to be stuck with constant "Copy
and Paste" over and over again?

Thank You So Very Much For You Consideration,
Rob