Copy Active sheet to new workbook.

[RAL2002]

I am trying to copy an active sheet to a new workbook with the following. The problem is that it is truncating
some of the cells that have too much text. Is there a way to make this work?

[vba]Option Explicit
Sub CreateSpecificationFile()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet

If MsgBox("Finalize ans save new speification file?" & vbCr & _
"This specification will be saved as selected" _
, vbYesNo, "New Specification") = vbNo Then Exit Sub

With Application
.ScreenUpdating = False

' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("PK12002")).Copy
On Error GoTo 0

For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[a1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate

Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm

' Remove column E from new worksheet
Range("E:E").Delete

' Input box to name new file
NewName = InputBox("ENTER A NAME FOR THIS SPECIFICATION New file _
will be saved in the original directory the master file is in.", "Name Specification File")

' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"

ActiveWorkbook.Close False
ActiveWorkbook.Close False

.ScreenUpdating = False


End With
Exit Sub

ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub[/vba]

[mdmackillop]

This appears to make a copy of the workbook, not a sheet to a new book as described.

[RAL2002]

I kind of mixed up two different macros. One of them copied the entire workbook the other specified a sheet name. My goal is to copy the values and formats from the active sheet and create a new workbooy with a dialog box to give it a name. Then close the original workbook witout saving.

[GTO]

Greetings,

As you mentioned that you had sort of stuck two macros together, this (hopefully) generally follows along w/what it looks like you are trying to accomplish:

In a Standard Module:
[vba]Option Explicit

Sub CopySheet()
Dim wb As Workbook
Dim wks As Worksheet
Dim n As Name
Dim strShName As String
Dim strFullname As String


If MsgBox("Would you like to save this sheet as its own Workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then

Set wks = ActiveSheet
'// Save the worksheet's name for suggested filename, as well as to retain //
'// the same name once it gets copied to the new book //
strShName = wks.Name

strFullname = Application.GetSaveAsFilename( _
InitialFilename:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Choose a Name")

If Not strFullname = "False" Then

'// Add a new one-sheet workbook//
Set wb = Workbooks.Add(xlWBATWorksheet)
'// Copy our activesheet and set a reference to it //
wks.Copy ThisWorkbook.Worksheets(1)
Set wks = ThisWorkbook.Worksheets(1)

'// Then with the copy, do whatever you want as to deleting formulas, etc //
With wks
.UsedRange.Value = .UsedRange.Value
.Hyperlinks.Delete
For Each n In .Names
n.Delete
Next
'// and move it to the new wb, AFTER the one blank sheet in the new wb //
.Move After:=Workbooks(wb.Name).Sheets(1)
End With

With wb
'// Delete the blank sheet and rename the copied sheet to the same name //
'// the original has //
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.Worksheets(1).Name = strShName

'// Saveas a new workbook. The error skipping is just so that if the //
'// user picks the name of an existing workbook and decides to cancel //
'// the save upon being warned. //
On Error Resume Next
.SaveAs Filename:=strFullname
On Error GoTo 0
End With
End If
End If
End Sub[/vba]

Hope this helps,

Mark

[mdmackillop]

Here's a very basic version. No bells and whistles.
[vba]
Option Explicit
Sub CopyActiveSheet()
Dim ws As Worksheet
Dim wb As Workbook
Dim Pth As String
Pth = ActiveWorkbook.Path & "\"
Set ws = ActiveSheet
ws.Copy
With ActiveWorkbook
ws.Cells.Copy .Sheets(1).Range("A1")
.SaveAs Pth & InputBox("File name") & ".xls"
.Close
End With
ActiveWorkbook.Close False
End Sub
[/vba]

[RAL2002]

Thank you for the quick replies.
Mark, I like the way yours brings up the save file dialog but, it is still truncating the cells with alot of text.

mdmackillop, I like yours because it does not truncate the cells.

The problem is I am not educated enought to combine the two without messing them up...

[mdmackillop]

I've pinched bits from Mark's code
[VBA]
Option Explicit
Sub CopyActiveSheet()
Dim ws As Worksheet, ws2 As Worksheet
Dim n As Name
Dim wb As Workbook
Dim Pth As String
Pth = ActiveWorkbook.Path & "\"
Set ws = ActiveSheet
ws.Copy
Set ws2 = ActiveSheet
With ActiveWorkbook
'Copy cells, including long text
ws.Cells.Copy .Sheets(1).Range("A1")
'Delete names
For Each n In .Names
n.Delete
Next
'Remove formulae & links
With ws2
.UsedRange.Value = .UsedRange.Value
.Hyperlinks.Delete
End With
'Save and close
.SaveAs Pth & InputBox("File name") & ".xls"
.Close
End With
ActiveWorkbook.Close False
End Sub

[/VBA]

[RAL2002]

mdmackillop,
Thank you once again for the quick responce.
Do you see any way to make the code posted by Mark copy the cells vs the worksheet? I like the pop up box and the choose a file name that his code does.
Thank You.

[RAL2002]

Gentlmen,
I played around a little and got the folowing to do exactly as I wanted:

[VBA]Option Explicit

Sub CopySheet()
Dim wb As Workbook
Dim wks As Worksheet
Dim n As Name
Dim strShName As String
Dim strFullname As String


If MsgBox("Would you like to finalize & save this specification as a new workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then

Set wks = ActiveSheet
'// Save the worksheet's name for suggested filename, as well as to retain //
'// the same name once it gets copied to the new book //
strShName = wks.Name

strFullname = Application.GetSaveAsFilename( _
InitialFileName:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Enter or Choose a Name")

If Not strFullname = "False" Then

'// Add a new one-sheet workbook//
Set wb = Workbooks.Add(xlWBATWorksheet)
'// Copy our activesheet and set a reference to it //
wks.Cells.Copy
Set wks = ThisWorkbook.Worksheets(1)

'// Then with the copy, do whatever you want as to deleting formulas, etc //
With wks
.UsedRange.Value = .UsedRange.Value
.Hyperlinks.Delete
.Range("E:E").Delete
For Each n In .Names
n.Delete
Next
'// and move it to the new wb, AFTER the one blank sheet in the new wb //
.Move After:=Workbooks(wb.Name).Sheets(1)
End With

With wb
'// Delete the blank sheet and rename the copied sheet to the same name //
'// the original has //
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.Worksheets(1).Name = strShName

'// Saveas a new workbook. The error skipping is just so that if the //
'// user picks the name of an existing workbook and decides to cancel //
'// the save upon being warned. //
On Error Resume Next
.SaveAs Filename:=strFullname
On Error GoTo 0
End With
End If
End If
End Sub
[/VBA]

Thank you again for your help. I will be working on thid project for a while and may come up with mre questions.

[RAL2002]

Well I thought it worked....
When I added some mor workseets to the workbook I found that the following was copying the first workseet instead of the active worksheet.

[VBA]Option Explicit

Sub CopySheet()
Dim wb As Workbook
Dim wks As Worksheet
Dim n As Name
Dim strShName As String
Dim strFullname As String


If MsgBox("Would you like to finalize & save this specification as a new workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then

Set wks = ActiveSheet
'// Save the worksheet's name for suggested filename, as well as to retain //
'// the same name once it gets copied to the new book //
strShName = wks.Name
wks.Unprotect ("specification")
strFullname = Application.GetSaveAsFilename( _
InitialFileName:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Enter or Choose a Name")

If Not strFullname = "False" Then

'// Add a new one-sheet workbook//
Set wb = Workbooks.Add(xlWBATWorksheet)
'// Copy our activesheet and set a reference to it //
wks.Cells.Copy
Set wks = ThisWorkbook.Worksheets(1)

'// Then with the copy, do whatever you want as to deleting formulas, etc //
With wks
.UsedRange.Value = .UsedRange.Value
.Hyperlinks.Delete
.Range("E:E").Delete
For Each n In .Names
n.Delete
Next
'// and move it to the new wb, AFTER the one blank sheet in the new wb //
.Move After:=Workbooks(wb.Name).Sheets(1)
End With

With wb
'// Delete the blank sheet and rename the copied sheet to the same name //
'// the original has //
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.Worksheets(1).Name = strShName
Application.CutCopyMode = False
'// Saveas a new workbook. The error skipping is just so that if the //
'// user picks the name of an existing workbook and decides to cancel //
'// the save upon being warned. //
On Error Resume Next
.SaveAs Filename:=strFullname
On Error GoTo 0
ActiveWorkbook.Close False
ActiveWorkbook.Close False
End With
End If
End If
End Sub
[/VBA]
Once again Thank You.

[GTO]

Greetings Ral,

Hi again - I didn't look at the code you just posted, but after spotting the .Copy (with no dest or paste), had tested a bit and concluded similar.

To see what your current code is doing, bring up the workbook as you did during testing. Then bring up the VBE window. REduce it to about 1/3 or 1/4 screen height so you can see a decent amount of the workbook behind it. With the code window active, place cursor somewhere in procedure. Start pressing F8 repeatedly, stopping to see what is actually happening.

Here is what I see:
[vba] If MsgBox("Would you like to finalize & save this specification as a new workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then

'// We first set a reference to the active sheet, so we have now have control over
'// it.
Set wks = ActiveSheet
strShName = wks.Name

'//We then got the user's choice as to a filename.
strFullname = Application.GetSaveAsFilename( _
InitialFileName:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Enter or Choose a Name")

'// We tested to make sure the user didn't cancel the saveas
If Not strFullname = "False" Then

'// Add a new one-sheet workbook//
Set wb = Workbooks.Add(xlWBATWorksheet)
'// Copy our activesheet and set a reference to it //
'***Whoa! Originally we had copied the sheet to index(1) {that is, to
' the leftmost position, so ...}
wks.Cells.Copy
'*** ...when we did this, we were now grabbing (setting a reference to / creating
' an object variable to) the copy, and thereafter we were working with the copy...
Set wks = ThisWorkbook.Worksheets(1)

'*** Now I hope I describe this sensibly: As we are no longer copying a sheet,
' resetting what wks refers to logically (least to the blonde guy) means the
' activesheet must have been index(1) or the rest would not be working.
' Further, if you follow your mods the rest of the way down, you will see that
' there's no Paste! (ie the Copy is doing nada)

'// Then with the copy, do whatever you want as to deleting formulas, etc //
With wks
.UsedRange.Value = .UsedRange.Value
.Hyperlinks.Delete
'*** I did note this addition***
.Range("E:E").Delete

'... remainder of code...
[/vba]

In re-reading your initial description, you seemed to want to just copy the sheet to a new workbook. Given the outcome of your latest code, I take it that you now want the original sheet to be moved to the new wb, minus of course hyperlinks / formulas / names?

Taking into account that you liked the saveas dialog, as well as correcting for the over 255 char cells (Shhhh... don't tell Malcom, but I might be swiping a bit) maybe this would work reliably?
[vba]Sub CopySheet()


Dim wb As Workbook, _
wks As Worksheet, _
n As Name, _
strShName As String, _
strFullname As String, _
lnk As Hyperlink


If MsgBox("Would you like to finalize & save this specification as a new workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then
Set wks = ActiveSheet
strShName = wks.Name
strFullname = Application.GetSaveAsFilename( _
InitialFilename:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Enter or Choose a Name")
If Not strFullname = "False" Then
Set wb = Workbooks.Add(xlWBATWorksheet)

With wks
'// Slower, but doesn't leave a dead address listed in the cell //
For Each lnk In .Hyperlinks
.Range(lnk.Range.Address).Value = Empty
Next
.UsedRange.Copy
.UsedRange.PasteSpecial Paste:=xlPasteValues
.Range("E:E").Delete
Application.CutCopyMode = False
.Move After:=Workbooks(wb.Name).Sheets(1)
End With
With wb
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.Worksheets(1).Name = strShName
.Worksheets(1).Cells(1, 1).Select
'// Thanks Malcom - I was trying to delete under the sheet, which //
'// appears to be a bust... //
For Each n In .Names
n.Delete
Next

On Error Resume Next
.SaveAs Filename:=strFullname
On Error GoTo 0
.Close False
End With
End If
ThisWorkbook.Close False
End If
End Sub[/vba]

Hope this helps,

Mark

PS - I ran out of time and need to hit the rack...did not test as to what junk (names or other) this leaves in the orig/parent workbook...

[GTO]

OOPS, a PS -

If you could use the little green/white "VBA" button above the msg window for code included, this will place tags that will format the code in a neater/easier to read manner.

Have a great day, this lad is out,

Mark

[mdmackillop]

If you want to select the sheet/sheets to be copied to an new book, I would create a userform with a listbox showing a list of sheet names. You could then either multi-selct to copy them to one book, or a new book for each depending on your coding.

[RAL2002]

Well that one didn't do it. I now have three sheets in my workbook, Cover, Table of Contents, PK12002-EH. There will eventually be upwards of 45 worksheets. My goal is to have the user select items from a list at various places. Once that is done they click a button that has this macro assigned to it. It then copies the values of the first four culunms of that active sheet and creates a new single sheet workbook gives the user the option of naming that workbook. Then close the original without saving the changes.

I'm sorry if I did not explain it well the first time around. This code below works as long as the sheet I want to copy is the first sheet in the original workbook. I was even able to protect the sheet and then udprotect it in the code to allow the copy.

[vba]Option Explicit

Sub CopySheet()
Dim wb As Workbook
Dim wks As Worksheet
Dim n As Name
Dim strShName As String
Dim strFullname As String


If MsgBox("Would you like to finalize & save this specification as a new workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then

Set wks = ActiveSheet
'// Save the worksheet's name for suggested filename, as well as to retain //
'// the same name once it gets copied to the new book //
strShName = wks.Name
wks.Unprotect ("specification")
strFullname = Application.GetSaveAsFilename( _
InitialFileName:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Enter or Choose a Name")

If Not strFullname = "False" Then

'// Add a new one-sheet workbook//
Set wb = Workbooks.Add(xlWBATWorksheet)
'// Copy our activesheet and set a reference to it //
wks.Cells.Copy
Set wks = ThisWorkbook.Worksheets(1)

'// Then with the copy, do whatever you want as to deleting formulas, etc //
With wks
.UsedRange.Value = .UsedRange.Value
.Hyperlinks.Delete
.Range("E:E").Delete
For Each n In .Names
n.Delete
Next
'// and move it to the new wb, AFTER the one blank sheet in the new wb //
.Move After:=Workbooks(wb.Name).Sheets(1)
End With

With wb
'// Delete the blank sheet and rename the copied sheet to the same name //
'// the original has //
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.Worksheets(1).Name = strShName
Application.CutCopyMode = False
'// Saveas a new workbook. The error skipping is just so that if the //
'// user picks the name of an existing workbook and decides to cancel //
'// the save upon being warned. //
On Error Resume Next
.SaveAs Filename:=strFullname
On Error GoTo 0
ActiveWorkbook.Close False
ActiveWorkbook.Close False
End With
End If
End If
End Sub
[/vba]

Once again thank you for your generous help.

PS. Sorry about the paste thing I got it now.

[mdmackillop]

Here's a userform to allow sheet selection. There's a bug or two in the copysheet code, but it shows the principle.

[RAL2002]

mdmackillop,

Thank you for this form, It is not what I am looking for in this project but may work in another one perfectly! With this workbook I only want the user to be able copy the active worksheet to a new workbook. The last code I posted works fine all except for it is copying the first sheet, not the active sheet.
Thank you.

Mark,
Thank you for the direction on posting. It looks like a moderator corected my previous posts.

[RAL2002]

Mark,

I played around with your last post. It was having a problem at the part you added to remove hyperlinks. I removed part of it and it seems to be working. I also added a line to unprotact the sheet so I can protect it from users trying to change things. Here is what I wound up with.

[vba]Sub CopySheet()


Dim wb As Workbook, _
wks As Worksheet, _
n As Name, _
strShName As String, _
strFullname As String, _
lnk As Hyperlink


If MsgBox("Would you like to finalize & save this specification as a new workbook?", _
vbYesNo + vbQuestion, "") = vbYes Then
Set wks = ActiveSheet
strShName = wks.Name
strFullname = Application.GetSaveAsFilename( _
InitialFileName:=wks.Name & ".xls", _
FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Enter or Choose a Name")
If Not strFullname = "False" Then
Set wb = Workbooks.Add(xlWBATWorksheet)

With wks
'// Slower, but doesn't leave a dead address listed in the cell //
For Each lnk In .Hyperlinks
Next
.Unprotect ("specification")
.UsedRange.Copy
.UsedRange.PasteSpecial Paste:=xlPasteValues
.Range("E:E").Delete
Application.CutCopyMode = False
.Move After:=Workbooks(wb.Name).Sheets(1)
End With
With wb
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.Worksheets(1).Name = strShName
.Worksheets(1).Cells(1, 1).Select
'// Thanks Malcom - I was trying to delete under the sheet, which //
'// appears to be a bust... //
For Each n In .Names
n.Delete
Next

On Error Resume Next
.SaveAs Filename:=strFullname
On Error GoTo 0
.Close False
End With
End If
ThisWorkbook.Close False
End If
End Sub
[/vba]


I do not have any hyperlinks in that sheet. Does it look like I removed it ok. Can the line (For Each Ink in .Hyperlinks) be removed?
Thank you again for the help.

[Aussiebear]

Do you need to protect the sheet again?

[GTO]

Hey there,

I did a quick read and only noted adding the .Unprotect and as you mentioned, removing the check for hyperlinks. I think that should be fine and yes, remove:

[vba] '// Slower, but doesn't leave a dead address listed in the cell //
For Each lnk In .Hyperlinks
Next
[/vba]

...as well as the 'lnk As Hyperlink' at the top.

Sorry about the error, I failed to test for no links and w/o checking, I bet the 'lnk.Range.Address' jams it if there are no links.

Phew! I'm glad we got 'er working!

@MD:

Partially an excuse to say Hi, but dang(!) the userform is slick

[GTO]

Hi Ted,

The orig wb is being closed w/o saving, so I don't think so.

Mark