Copy named range from file list to summary workbook

[plantechbl]

I have a named range "JOBDATA" (=Summary!$A$2:$K$5) in many job
specific workbooks. I have the list of the individual .XLS path and
filenames (M:\Projects\12345-Testing\12345-Testing.xls) in an overall
summary job information workbook. I need to loop through all the
individual job files and copy the "JOBDATA" named range to a
"JOB_SUMMARY" worksheet. Basically I need to "Open" the job specific
file, "Copy" the named range, "Paste Special" values into the first
empty row of the "JOB_SUMMARY" worksheet, "Close" the file without
saving, then loop through the process for the remainder of the job
files. I have checked Ron de Bruin's site
http://www.rondebruin.nl/ado.htm#files and he has some good examples
but I don't have sufficient understanding to modify them for my
application. Thanks in advance for any help.

 

[Ron de Bruin]

Hi

You can do it like this

In your workbook there is a sheet named "FileNames" with the path/file names in column A
Be sure that this sheet is not the first sheet because it copy the data to the first sheet of this workbook

Change this line to yournamed range(it now use A1:C1 of the first sheet)
Set sourceRange = mybook.Worksheets(1).Range("A1:C1")



Sub Example2()
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim FileCell As Range


On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0

On Error Resume Next
For Each FileCell In basebook.Sheets("FileNames").Range("A:A") _
.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FileCell
End If
End If
Next FileCell
On Error GoTo 0

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyFiles(Fnum))
Set sourceRange = mybook.Worksheets(1).Range("A1:C1")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("A" & rnum)


sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only the values

' With sourceRange
' Set destrange = basebook.Worksheets(1).Cells(rnum, "A"). _
' Resize(.Rows.Count, .Columns.Count)
' End With
' destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub

 

[plantechbl]

Ron,

Thank you very much for your prompt response and your help. I had to
make a few modifications to get the code to work with my specific
sheets but it works and works great! I have commented the mods in the
following code. One part I have done a klunky work around on is the
column headings that are cleared by
"basebook.Worksheets(1).Cells.Clear"
I created a macro to reinsert them but if I could clear all rows from
the second row down it would be cleaner.
This is the first time that you have helped me out directly but I have
gotten a great deal of help from your website and your MANY other posts
helping out other people.

Modified code:

Sub Example2()
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim FileCell As Range


On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
'Ron, can this be set to leave row 1 column headings?
'I have worked around this be inserting a
'row with the column headings
'InsertColHeadings macro
basebook.Worksheets(1).Cells.Clear
rnum = 1


'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0


On Error Resume Next
For Each FileCell In basebook.Sheets("FileNames").Range("A:A") _
.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FileCell
End If
End If
Next FileCell
On Error GoTo 0


'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyFiles(Fnum))
'Ron, I had to make the "Summary" Sheet active
Sheets("Summary").Select
Set sourceRange =
mybook.Worksheets("Summary").Range("JOBDATA")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("A" & rnum)


'sourceRange.Copy destrange
' Instead of this line you can use the code below to copy
only the values


With sourceRange
Set destrange =
basebook.Worksheets(1).Cells(rnum, "A"). _

Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value


rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
' Inserts column headings deleted by
' basebook.Worksheets(1).Cells.Clear
Call InsertColHeadings
Call Autofilter
End Sub

Again my sincere thanks.
Bill

 

[Ron de Bruin]

Hi Bill

'Ron, I had to make the "Summary" Sheet active
Sheets("Summary").Select

That is very strange, are you sure ?


Use this
basebook.Worksheets(1).Range("A2:IV" & Rows.Count).Clear


I also add a example for this on my site
http://www.rondebruin.nl/copy3.htm

 

[plantechbl]

Hi Ron,

You are correct...I commented out the line and it functions as you had
written it originally. It must have been some of the other mods that I
was making at the time. And the updated line re: row 1 now preserves
the column headings.

Sincere Thanks,
Bill

 

[Ron de Bruin]

You are welcome