Solved: Function to copy sheet to new file

Hi everyone!

I'm not a programmer, but I'm trying to create a function that copy a range of cells from a sheet in a workbook to a new workbook as values, but with the same cells format.
In the same function, I would like to have the option of saving the sheet in a complete new workbook, or open an existing one, and add the new sheet.
Is this possible to do in VBA???
Here's the code I've done so far, but it only saves the sheet into a new file:
[vba]
Sub Save_CostSheet()
Dim NewFileName As String
Dim NewTitle As String
Dim SheetName As String
Dim CurrentBook As Workbook
Dim CurrentSheet As Worksheet
'Name of the cost sheet title.
NewTitle = InputBox("Please Specify the Title for this Cost Sheet", "New Cost Sheet")
If NewTitle = "False" Or NewTitle = "" Then
Exit Sub
End If
'Getting the name of the new file.
NewFileName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Save As")
If NewFileName = "False" Or NewTitle = "" Then
Exit Sub
End If
'Saving sheet name and copy.
SheetName = ActiveSheet.Name
Sheets(SheetName).Copy
'Saving the new file with selected sheet.
If LCase$(Right$(NewFileName, 4)) <> ".xls" Then
NewFileName = NewFileName & ".xls"
End If
Set CurrentBook = ActiveWorkbook
With CurrentBook
If NewFileName <> "False" Then
Set CurrentSheet = ActiveSheet
With CurrentSheet
.Range("A1").Value = NewTitle
End With
.SaveAs NewFileName
.Close
Else
.Close False
Exit Sub
End If
End With
End Sub
[/vba]

This code as also a problem with the file created. Everytime I open the new file, a message popup saying that the file is in a different format than specified by the file extension. Does anyone knows how to avoid this?

Thanks by the help!!!

I think this is what you wanted. I've simplified your code in a few areas, especially where the new workbook is opened. Basically a new blank workbook is added and the user can choose their name when they save it.

[vba]
Sub Save_CostSheet()
Dim i As Integer
Dim numberOpenWorkbooks As Integer
Dim choose As String
Dim NewFileName As String
Dim NewTitle As String
Dim SheetName As String
Dim CurrentBook As Workbook
Dim CurrentSheet As Worksheet
Dim NewBook As Workbook
Dim ExistingWB As String


'Name of the cost sheet title.
NewTitle = InputBox("Please Specify the Title for this Cost Sheet", "New Cost Sheet")
If NewTitle = "False" Or NewTitle = "" Then
Exit Sub
End If
'Set the location of the starting point

Set CurrentBook = ActiveWorkbook
Set CurrentSheet = ActiveSheet

'count original number of open workbooks
numberOpenWorkbooks = Application.Workbooks.Count


'work out whether to append to existing Workbook or create new one
repeat_question:
choose = InputBox("Do you want to open an existing Workbook <1> or save to a new Workbook <2>", "Select location for new (copied) sheet")
Select Case Val(choose):
Case 0:
Exit Sub
Case 1:
ExistingWB = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook")
Workbooks.Open Filename:=ExistingWB
Case 2:
Application.Workbooks.Add
Case Else:
GoTo repeat_question
End Select
'set the newBook as the latest member of the Workbooks collection
Set NewBook = Application.Workbooks(numberOpenWorkbooks + 1)
'Copy the currect sheet before the first sheet of the newly opened or added workbook
CurrentSheet.Copy Before:=NewBook.Sheets(1)

'Set the new Title of the new sheet
NewBook.Sheets(1).Range("A1").Value = NewTitle

End Sub

[/vba]

Hi Teeroy,

Thanks for your help! Definitly, your code is better than mine, just added it the option to ask for the name of the new file.
And it's here where I stil struggle with a problem. After the function run and create the new workbook with my sheet on it, I save the file and close it. Then, if I try to open the file, I receive a message saying that the file format is different than the specified by the file extension.
Do you know why this happen, and how to resolve it?

Many thanks! :beerchug:

Hi Sersan,

I didn't get that error testing with both Excel 2003 and 2010.

Are you running Excel 2007 or 2010? If so this error is because the new format extension is .xlsx (or .xlsm if macros are included) not .xls. If you allow the user to save you won't get that error. You may also try not having a file extension on the FileName variable as I think the correct type will be added by default (I'm not able to test this 'til later).

If the above doesn't work please post your new code to see whether the changes you've made have affected the running.

Hi,
Sorry for late reply. I've try to make the function to save always as xlsx file, but stil not able to do that.
One small note, the original file extension is xls, don't know if it makes any difference.
This is my current code:
[vba]
Sub Save_CostSheet()

Dim csFileName As String
Dim csTitle As String
Dim opChoose As String
Dim wbExisting As String
Dim wbOpenNumber As Integer
Dim wbCurrent As Workbook
Dim wbNew As Workbook
Dim stCurrent As Worksheet

'Name of the cost sheet title.
csTitle = InputBox("Please Specify the Title for this Cost Sheet", "New Cost Sheet")
If csTitle = "False" Or csTitle = "" Then
Exit Sub
End If

'Set the location of the starting point.
Set wbCurrent = ActiveWorkbook
Set stCurrent = ActiveSheet

'Count original number of open workbooks.
wbOpenNumber = Application.Workbooks.Count

'Choose to open file or to create a new one.
Repeat_Question:
opChoose = InputBox("Do you Want to Open an Existing File <1> or to Save to a New File <2>", "Select Option")
If opChoose = "False" Or opChoose = "" Then
Exit Sub
End If
Select Case Val(opChoose):
Case 0:
Exit Sub
Case 1:
wbExisting = Application.GetOpenFilename(filefilter:="Microsoft Excel Workbooks, *.xlsx", Title:="Open Workbook")
If wbExisting = "False" Or wbExisting = "" Then
Exit Sub
End If
Workbooks.Open Filename:=wbExisting
Case 2:
csFileName = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Workbooks, *.xlsx", Title:="Save Workbook As")
If csFileName = "False" Or csFileName = "" Then
Exit Sub
End If
Application.Workbooks.Add
ActiveWorkbook.SaveAs csFileName
Case Else:
GoTo Repeat_Question
End Select

'Set the new sheet as the latest member of the workbook.
Set wbNew = Application.Workbooks(wbOpenNumber + 1)

'Copy the new sheet before the first sheet of the workbook opened or created.
stCurrent.Copy Before:=wbNew.Sheets(1)

'Set the title of the new sheet.
wbNew.Sheets(1).Range("A1").Value = csTitle
End Sub
[/vba]

Try
[VBA]ActiveWorkbook.SaveAs csFileName, FileFormat:=xlWorkbookDefault[/VBA]

I think Tinbendr's got your fix but have a look at this link for some more information if you need it.

http://www.rondebruin.nl/saveas.htm

To save a worksheet as a new workbook, using the same extension and the same fileformat:

[vba]Sub snb()
With ThisWorkbook
.Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs Replace(.FullName, ".", "_001."), .FileFormat
ActiveWorkbook.close
End With
End Sub[/vba]

If you want all formulae being removed:

[vba]Sub snb()
With ThisWorkbook
.Sheets("Sheet1").Copy
ActiveWorkbook.sheets(1).cells.value=ActiveWorkbook.Sheets(1).Cells.value
ActiveWorkbook.SaveAs Replace(.FullName, ".", "_001."), .FileFormat
ActiveWorkbook.close
End With
End Sub[/vba]

Thanks guys for your help! :bow:
I think that now, I can finish my project... :beerchug:

Guys, after all, I still need your help!!! :dunno

Now, I need to make the sheet in the new workbook only as values. I know how to copy and paste as values a selected range, but is it possible to select all sheet, copy it and paste it as values?

Then, I'm trying to delete the sheets in the new workbook "Sheet1, Sheet2 and Sheet3". It's easy to delete it, but how to manage the error I found when I try to delete, and the sheet doesn't exists anymore?

Finaly, what's the best way to delete selected rows and columns?

Thanks mates!

Please start a new thread in the forum