nicksinthemi
04-04-2012, 08:45 AM
Got this great snipit of code that works wonders. Only problem is that the sheet naming convention doesn't really work.
Anyone know if I can change that second line to name the new sheet after the filename?
Sub CopySameSheetFrmWbs()
Dim wbOpen As Workbook
Dim wbNew As Workbook
'Change Path
Const strPath As String = "C:\Excel\"
Dim strExtension As String
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
'Change extension
strExtension = Dir(strPath & "*.xls")
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Excel\TemplateCollation", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
.Sheets("Master").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Anyone know if I can change that second line to name the new sheet after the filename?
Sub CopySameSheetFrmWbs()
Dim wbOpen As Workbook
Dim wbNew As Workbook
'Change Path
Const strPath As String = "C:\Excel\"
Dim strExtension As String
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
'Change extension
strExtension = Dir(strPath & "*.xls")
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Excel\TemplateCollation", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
.Sheets("Master").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub