A
Anthony Gobel
From the suggestion of a friend, I looked in here for an example to help me with a problem. I found one posted a couple of days ago by Dave Peterson. It seems to work great, but I am looking for some assistance to make a slight modification. I know excel well, but not VBA. Right now it looks like this is looking into a specific folder to get file names. What I would like to be able to do is make it look on a sheet in a specific column and get the file names to combine from there. Say for instance the file names are listed in column "E". Is there a way to make this code look in column "E", and use all the files listed there instead of a specific folder
Option Explici
Sub CombineWorkbooks(
Dim LastRow As Lon
Dim basebook As Workboo
Dim i As Lon
Dim mybook As Workboo
Dim DestCell As Rang
Dim RngToCopy As Rang
With Applicatio
.DisplayAlerts = Fals
.EnableEvents = Fals
.ScreenUpdating = Fals
End Wit
With Application.FileSearc
.NewSearc
'Change this to your director
.LookIn = ThisWorkbook.Path & "\ProgramData\"
.SearchSubFolders = Fals
.FileType = msoFileTypeExcelWorkbook
If .Execute() > 0 The
Set basebook = Workbooks.Open(.FoundFiles(1))
With basebook.Worksheets(1
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp
End With
For i = 2 To .FoundFiles.Coun
Set mybook = Workbooks.Open(.FoundFiles(i)
With ActiveShee
'column R = 18th colum
Set RngToCopy = .Range("a1:R" &
.Cells(.Rows.Count, "A").End(xlUp).Row
End With
If (DestCell.Row + RngToCopy.Rows.Count)
< DestCell.Parent.Rows.Count The
'ok to paste, just come down one
Set DestCell = DestCell.Offset(1, 0
Els
'too many rows, make a new shee
Set DestCell = basebook.Worksheets.Add.Range("a1"
End If
RngToCopy.Copy
Destination:=DestCel
Set DestCell = DestCell.Offset(RngToCopy.Rows.Count)
mybook.Clos
Next
'ChDir ThisWorkbook.Path & "\ProgramData\FileData\Report\
ActiveWorkbook.SaveAs
Filename:=ThisWorkbook.Path & "\ProgramData\FileData\Report\"
& "Report1.xls",
FileFormat:=xlNormal, CreateBackup:=Fals
'ActiveWorkbook.Close savechanges:=false 'just save
End I
End Wit
With Applicatio
.DisplayAlerts = Tru
.EnableEvents = Tru
End Wit
End Su
I don't really know if this is something that can be done or not, but if anybody has any ideas, it would be very helpful
Anthony
Option Explici
Sub CombineWorkbooks(
Dim LastRow As Lon
Dim basebook As Workboo
Dim i As Lon
Dim mybook As Workboo
Dim DestCell As Rang
Dim RngToCopy As Rang
With Applicatio
.DisplayAlerts = Fals
.EnableEvents = Fals
.ScreenUpdating = Fals
End Wit
With Application.FileSearc
.NewSearc
'Change this to your director
.LookIn = ThisWorkbook.Path & "\ProgramData\"
.SearchSubFolders = Fals
.FileType = msoFileTypeExcelWorkbook
If .Execute() > 0 The
Set basebook = Workbooks.Open(.FoundFiles(1))
With basebook.Worksheets(1
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp
End With
For i = 2 To .FoundFiles.Coun
Set mybook = Workbooks.Open(.FoundFiles(i)
With ActiveShee
'column R = 18th colum
Set RngToCopy = .Range("a1:R" &
.Cells(.Rows.Count, "A").End(xlUp).Row
End With
If (DestCell.Row + RngToCopy.Rows.Count)
< DestCell.Parent.Rows.Count The
'ok to paste, just come down one
Set DestCell = DestCell.Offset(1, 0
Els
'too many rows, make a new shee
Set DestCell = basebook.Worksheets.Add.Range("a1"
End If
RngToCopy.Copy
Destination:=DestCel
Set DestCell = DestCell.Offset(RngToCopy.Rows.Count)
mybook.Clos
Next
'ChDir ThisWorkbook.Path & "\ProgramData\FileData\Report\
ActiveWorkbook.SaveAs
Filename:=ThisWorkbook.Path & "\ProgramData\FileData\Report\"
& "Report1.xls",
FileFormat:=xlNormal, CreateBackup:=Fals
'ActiveWorkbook.Close savechanges:=false 'just save
End I
End Wit
With Applicatio
.DisplayAlerts = Tru
.EnableEvents = Tru
End Wit
End Su
I don't really know if this is something that can be done or not, but if anybody has any ideas, it would be very helpful
Anthony