Solved: Copy worksheet to new workbook

[Croeg]

Hello there,

I?ve been searching posts all day and can?t seem to find a solution to my problem.

I?ve created a form that populates cells in a worksheet named ?Metro? (one of many sheets) of a spreadsheet named MetroSheet.xls.

Here?s what I would like to do:

Save Worksheet "Metro" (only) in a new workbook changing its workbook name by using current cell values like: Sheets("Metro").Range("C5").Text & "_" & Sheets("Metro").Range("D7").Text & ?.xls? ?. which would equate to New York_50699.xls

I would like to have this new workbook saved in an existing folder on my C drive by again using current cell values that were input into the form. For example: strPath = ?C:\Automated Metro\? & Sheets("Metro").Range("C5").Text ?..which would equate to C:\Automated Metro\New York\

I would like the new workbook to still be visible for making any last minute changes before closing while the original workbook ?MetroSheets? is closed.

Thanks in advance !!!

Croeg

[mdmackillop]

Hi Croeg,
Welcome to VBAX
[vba]
Option Explicit
Sub CopySheet()
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = Sheets("Metro")
On Error Resume Next
ChDir "C:\Automated Metro\" & ws.Range("C5")
If Err.Number = 76 Then MkDir "C:\Automated Metro\" & ws.Range("C5")
ws.Copy
ActiveWorkbook.SaveAs Filename:="C:\Automated Metro\" & ws.Range("C5") & "\" & _
ws.Range("C5") & "_" & ws.Range("D7") & ".xls"
wb.Close True
End Sub

[/vba]

[Croeg]

mdmackillop,

THIS IS GREAT!!!! Thanks so much for your help. I have been trying to piece code together all day.

The only alterations I would like to make to it (if possible) would be to keep the new worksheet open for users to make changes if needed. Currently, both spreadsheets close down.

Thanks again !

Croeg

[malik641]

I believe this will do it (using Malcolm's code):
[vba]Option Explicit
Sub CopySheet()
Dim wb As Workbook, newWB As Workbook
Dim ws As Worksheet, wsSheets As Worksheet
Set wb = ThisWorkbook
Set ws = Sheets("Metro")
On Error Resume Next
ChDir "C:\Automated Metro\" & ws.Range("C5")
If Err.Number = 76 Then MkDir "C:\Automated Metro\" & ws.Range("C5")

Set newWB = Workbooks.Add
ws.Copy before:=newWB.Sheets(1)

Application.DisplayAlerts = False
For Each wsSheets In newWB.Sheets
If wsSheets.Name <> "Metro" Then wsSheets.Delete
Next
Application.DisplayAlerts = True

newWB.SaveAs Filename:="C:\Automated Metro\" & ws.Range("C5") & "\" & _
ws.Range("C5") & "_" & ws.Range("D7") & ".xls"
wb.Close True
End Sub
[/vba]And welcome to VBAX

EDIT: I changed some of the code.

[Croeg]

Hi Joseph,

Thanks for making the changes....works perfectly! I can't thank you both (mdmackillop) enough.


Croeg

[mdmackillop]

Currently, both spreadsheets close down.
Croeg

Strange. The new book does not close for me, and there is no instruction to to so. How about you Joseph?

[malik641]

Actually I didn't test your code until just now. It doesn't create the directory for me. The new workbook does not close for me...but it is not saved as the correct filename (or at all)...because the directory does not exists for some reason.


...After some testing I find that I can't create a directory inside a directory that doesn't already exist (i.e. a folder inside a folder that does not exists).

This worked perfect for me (changing your code just slightly...)
[vba]Sub CopySheet()
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = Sheets("Metro")
On Error Resume Next
ChDir "C:\Automated Metro\" & ws.Range("C5").Text
If Err.Number = 76 Then
MkDir "C:\Automated Metro\"
MkDir "C:\Automated Metro\" & Range("C5").Text
End If
ws.Copy
ActiveWorkbook.SaveAs Filename:="C:\Automated Metro\" & Range("C5").Text & "\" & _
ws.Range("C5").Text & "_" & ws.Range("D7").Text & ".xls"
wb.Close True
End Sub[/vba]
Even after repeated MkDir of Automated Metro...it does not overwrite anything.

[mdmackillop]

Thanks Joseph. I made the assumption that the main folder existed, but no harm in making sure!

[malik641]

Thanks Joseph. I made the assumption that the main folder existed, but no harm in making sure!

No problem

I wonder if Croeg can use that code with no problems too. Hey Croeg, give the code in post 7 a try, let us know

[Croeg]

Hi malik641,

Sorry for the late reply ! The code in post 7 works as well.

I hate to ask this but is it possible to alter this code to save the spreadsheet to a word doc instead? Alterations that I need to make to the the spreadsheet AFTER creation are proving to be difficult because I keep getting "merged cell" errors when I try to paste data. I attached an example of what the sheet looks like after the code you all so graciously provided to me.

I entered a message in cell A21 with an explanation.

Thanks again,

Croeg

[Croeg]

Hello All,

Thanks to the Kbase section of this forum, I was able to overcome my obstacle of saving a worksheet as a word doc by using bookmarks. I can't seem to work my way around saving the new word doc as Sheets("Metro").Range("C5").Text & "_" & Sheets(Metro").Range("D7").Text & ".doc"

Here's my altered code by Ken Puls in the Kbase section:

[VBA] Option Explicit
Sub BCMerge()
Dim pappWord As Object
Dim docWord As Object
Dim wb As Excel.Workbook
Dim xlName As Excel.Name
'Dim TodayDate As String
Dim Path As String
On Error Resume Next
ChDir "C:\Automated Metro\Metro PCI Cover Page\" & wb.Range("C5")
If Err.Number = 76 Then MkDir "C:\Automated Metro\Metro PCI Cover Page\" & wb.Range("C5")

Set wb = ActiveWorkbook

'TodayDate = Format(Date, "mmmm d, yyyy")
Path = wb.Path & "\MetroTemplate.dot"

On Error GoTo ErrorHandler
'Create a new Word Session
Set pappWord = CreateObject("Word.Application")

On Error GoTo ErrorHandler
'Open document in word
Set docWord = pappWord.Documents.Add(Path)
'Loop through names in the activeworkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 1
.Activate
End With
'Next
Application.DisplayAlerts = True

pappWord.saveas FileName:="C:\Automated Metro\Metro PCI Cover Page\" & wb.Range("C5") & "\" & _
wb.Range("C5") & "_" & wb.Range("D7") & ".doc"

'Release the Word object to save memory and exit macro
ErrorExit:
Set pappWord = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not pappWord Is Nothing Then
pappWord.Quit False
End If
Resume ErrorExit
End If

With wb
Application.IgnoreRemoteRequests = False
wb.Close True
End With

End Sub[/VBA]


Thanks for any assistance !!

Croeg