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" <(E-Mail Removed)> wrote in message news:(E-Mail Removed)...
>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
>
Similar Threads
