Solved: How can I copy sheet 1 from multiple spreadsheets to one new workbook?

Hi All,

I have c. 200 spreadsheets in a folder, I need to quickly copy sheet 1 of each of these and paste them into one workbook. I would also like to name each sheet in the new workbook as the last 9 characters of the original filename.

Can anyway help with an easy way to do this.

Thanks,

Marshybid

[vba]

Sub LoopFiles()
Dim FSO As Object
Dim Folder As Object
Dim file As Object
Dim wb As Workbook
Dim wbNew As Workbook

Set wbNew = Workbooks.Add
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder("c:\Test")

For Each file In Folder.Files

If file.Type Like "Microsoft*Excel*Worksheet*" Then

Set wb = Workbooks.Open(Filename:=file.Path)
wb.Worksheets(1).Copy after:=wbNew.Worksheets(wbNew.Worksheets.Count)
wbNew.Worksheets(wbNew.Worksheets.Count).Name = Left$(wb.Name, 9)
wb.Close savechanges:=False
End If
Next file

Application.DisplayAlerts = False
wbNew.Worksheets(3).Delete
wbNew.Worksheets(2).Delete
wbNew.Worksheets(1).Delete
Application.DisplayAlerts = True

Set wb = Nothing
Set wbNew = Nothing
Set file = Nothing
Set Folder = Nothing
Set FSO = Nothing

End Sub
[/vba]

Thanks Bob, that worked a treat and aved me about 3 hours of manula copy and paste.

Marking as solved.

Marshybid :hi: