VBA copy worksheet to new file

[Shadkng]

Hi, I would like to copy one tab/sheet form my workbook and have it saved to a new file. Can the file be saved under the tab name and placed in the same directory as the original workbook? It would be OK to keep saving over the previous file. I also need the cell formulas changed to values in the process. After searching I see this is a common need but I haven't come across exactly what I need. The closest I have found is the code below which creates the workbook but doesn't save it - I don't know too much about code so I don't know if this code is efficient. It does change the formulas to values. Any help is appreciated.

Sub SampleMacro()
Dim SrcWB As Workbook, TrgtWB As Workbook
Dim Sh As Worksheet
Dim MyArray As Variant, ShName As Variant
Dim Matched As Boolean
Application.ScreenUpdating = False
MyArray = Array("LABELS") 'Change the sheet names as required
Set SrcWB = ThisWorkbook
Set TrgtWB = Workbooks.Add
Application.CopyObjectsWithCells = False
SrcWB.Worksheets(MyArray).Copy Before:=TrgtWB.Worksheets(1)
Application.CopyObjectsWithCells = True
For Each Sh In TrgtWB.Worksheets
With Cells
.Copy
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
End With
Range("A1").Select
Matched = False
For Each ShName In MyArray
If ShName = Sh.Name Then
Matched = True
Exit For
End If
Next
If Not Matched Then
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End If
Next Sh
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub

 

[mumps]

Try:

Sub SaveSheet()
    Application.ScreenUpdating = False
    Sheets("[COLOR="#FF0000"]Sheet1[/COLOR]").Copy
    ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
    Application.ScreenUpdating = True
End Sub

Please note: when saving the file, it will over-write any existing file with the same name. Change the sheet name (in red) to suit your needs.

 

[Shadkng]

Works perfectly thanks! The only thing I changed was to add a few lines to delete shapes on the newly created sheet, but I was getting a prompt to save the file. So I disabled the "displayAlerts" line and the prompt went away. Is that OK?

Sub SaveSheet()
Application.ScreenUpdating = False
Sheets("LABELS").Copy
ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & ActiveSheet.Name & ".xlsx"
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
'Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

 

[mumps]

Did you want to delete the shapes before or after the file is saved?

 

[Shadkng]

No, I want the shapes to remain in the original file, just removed in the new one.

 

[Shadkng]

Actually the lines I added to remove shapes are not working as I thought. Also, can we change active sheet to specify the worksheet "LABELS"? I don't want in run my accident from another sheet. Thanks

 

[mumps]

Try:

Sub SaveSheet()
    Application.ScreenUpdating = False
    Dim shp As Shape
    Sheets("LABELS").Copy
    ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next shp
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & ActiveSheet.Name & ".xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[Shadkng]

It doesn't see to be working now - it's not saving the sheet. But when I run the macro it looks like it running.

 

[Shadkng]

Hi, I found the problem. I think you left out a slash in the save as path. I compared it to your previous one. Thanks again works great.

 

[Shadkng]

One more revision - I may want to use the path below to save the file. Thanks

C:\Users\Steve\Desktop\Dropbox\Quotes Steve\LABELS