Copy Multiple Workbooks to Worksheet
 

I have used the following code thanks to Ron DeBruin and it works
great to copy the text in multiple workbooks to one sheet. The code
puts the workbook name in the cell at the header row of each sheet
range copied. How can I modify the code to add the workbook name in a
cell on every row? I tried to add a line with filldown, but that only
does the first set, and not the remaining. Any ideas?


Option Explicit

'***Copy a Range from each workbook***
'
'This two examples will copy Range("A1:C1") from the first sheet of
each workbook.
'Change the folder "C:\Data" 0r "\\ComputerName\YourFolder" to your
folder.

'Note: The second macro is also working if your files are in a network
folder.

Sub Example1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

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

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)
Set sourceRange = mybook.Worksheets(1).Range("A1:C10")'
CHANGED Range("A1:C1")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want

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

mybook.Close False
rnum = rnum + SourceRcount
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Copy Multiple Workbooks to Worksheet
 

You can use this Darrell

basebook.Worksheets(1).Cells(rnum, "D").Resize(SourceRcount).Value = mybook.Name


--

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


"Darrell Lankford" wrote in message s.com...
I have used the following code thanks to Ron DeBruin and it works
great to copy the text in multiple workbooks to one sheet. The code
puts the workbook name in the cell at the header row of each sheet
range copied. How can I modify the code to add the workbook name in a
cell on every row? I tried to add a line with filldown, but that only
does the first set, and not the remaining. Any ideas?


Option Explicit

'***Copy a Range from each workbook***
'
'This two examples will copy Range("A1:C1") from the first sheet of
each workbook.
'Change the folder "C:\Data" 0r "\\ComputerName\YourFolder" to your
folder.

'Note: The second macro is also working if your files are in a network
folder.

Sub Example1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

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

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)
Set sourceRange = mybook.Worksheets(1).Range("A1:C10")'
CHANGED Range("A1:C1")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want

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

mybook.Close False
rnum = rnum + SourceRcount
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Copy Multiple Workbooks to Worksheet
 

On Mar 9, 1:22 pm, "Ron de Bruin" wrote:
You can use this Darrell

basebook.Worksheets(1).Cells(rnum, "D").Resize(SourceRcount).Value = mybook.Name

--

Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm



"Darrell Lankford" wrote in legroups.com...
I have used the following code thanks to Ron DeBruin and it works
great to copy the text in multiple workbooks to one sheet. The code
puts the workbook name in the cell at the header row of each sheet
range copied. How can I modify the code to add the workbook name in a
cell on every row? I tried to add a line with filldown, but that only
does the first set, and not the remaining. Any ideas?

Option Explicit

'***Copy a Range from each workbook***
'
'This two examples will copy Range("A1:C1") from the first sheet of
each workbook.
'Change the folder "C:\Data" 0r "\\ComputerName\YourFolder" to your
folder.

'Note: The second macro is also working if your files are in a network
folder.

Sub Example1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

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

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)
Set sourceRange = mybook.Worksheets(1).Range("A1:C10")'
CHANGED Range("A1:C1")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want

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

mybook.Close False
rnum = rnum + SourceRcount
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub- Hide quoted text -

- Show quoted text -

Ron,

That worked great!!

Thanks,
Darrell