Saving only current worksheet into new file

[BobC]

Hello,
I have an excel file with multiple worksheets. Want to be able to go into
any sheet as the active sheet, and run macro that will save just that
worksheet into a new file with the same filename with an extention. Eg, if
I'm in "datafile.xls", want to save just the active worksheet into a new file
called "datafile scrubbed.xls" and close the original file. Another way of
saying it is - delete all worksheets except one, and save as a new file and
close it out.

Can you help with that macro? Thanks so much, I really appreciate it!

 

[FSt1]

hi
here is an old lotus function call save range. i missed it when i switched
to excel.
i edited it somewhat for your perposes. if it doesn't suit, play with it.
the macro as i wrote it for me will save a range from a single cell to an
entire sheet....depending on what you select. in your case, you what the
entire sheet.
also since this is a personal macro, the error message at the end...ah....it
was ment for me. change to suit.

Sub mac1SaveRange()
'Macro written by FSt1 4/27/97
Dim cnt As Long
Dim cell As Range
'On Error GoTo err1
'MsgBox "You have selected range" & Selection.Address
'If Selection.Cells.Count = 1 Then
' If MsgBox("You have selected only one cell. Continue?????", _
vbYesNo, "Warning") = vbNo Then
' Exit Sub
' End If
'End If
'cnt = 0
'For Each cell In Selection
' If Not IsEmpty(cell) Then
' cnt = cnt + 1
' End If
'Next
'If cnt = 0 Then
'If MsgBox("There is no data in the selected range. Continue?!?!?!?!?", _
' vbYesNo, "Warning") = vbNo Then
' Exit Sub
' End If
'End If
'ActiveSheet.UsedRange.Select
'Selection.Copy
Activesheet.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Application.Dialogs(xlDialogSaveAs).Show
'err1:
' MsgBox ("Need a range to save, diphead.")
' Exit Sub
End Sub

if it don't suit your needs, maybe it will give you ideas.

Regards
FSt1

 

[OssieMac]

Hi Bob,

The following copies or moves a sheet to a new workbook and names the new
workbook as you requested. I have set it to create new workbook in same path.

This method copies everything including the Print page setups etc.

Note the lines 'ActiveSheet.Move and ActiveSheet.Copy with their comments.
Decide whether you want to delete it from the old workbook or simply copy it
and leave it in the old workbook and edit the comment character accordingly.

Sub Macro2()

Dim strWbName As String
Dim strWbNewName As String
Dim strPath As String
Dim strNewWbFileName As String

'Current workbook path
strPath = ActiveWorkbook.Path & "\"

'Current workbook name (including extension)
strWbName = ThisWorkbook.Name

'Cureent workbook with extension removed
strWbName = Left(strWbName, InStr(1, ThisWorkbook.Name, ".") - 1)

'New workbook name with "Scrubbed appended"
strWbNewName = strWbName & " Scrubbed"

'New workbook name prefixed with current path and file type appended
strNewWbFileName = strPath & strWbNewName & ".xls"

'ActiveSheet.Move 'Deletes sheet from original workbook
ActiveSheet.Copy 'Copies sheet without deleting from old workbook

ActiveWorkbook.SaveAs Filename:=strNewWbFileName, _
FileFormat:=xlNormal

ThisWorkbook.Save

ThisWorkbook.Close

End Sub

 

[BobC]

THANK YOU both, very much! I truly appreciate the help!