programmatically save new workbook with custom name & location

[Carlee]

Good morning,
The following code works to copy the last submission entered in the "Site
Reading Log' to a new workbook. The problem is that this code doesn't name
the new workbook.

Question:
Can this code be modified to:
a) save the new workbook as 'Copreco Reading'
b) save the new workbook to the users Desktop

Sub ExportCoprecoReadingData()
Const sourceSheet = "Site Reading Log" ' source
Dim sourceBook As String
Dim destBook As String
Dim sourceRange As Range
Dim destRange As Range

Application.ScreenUpdating = False
sourceBook = ThisWorkbook.Name
Workbooks.Add ' create new book
destBook = ActiveWorkbook.Name
Windows(sourceBook).Activate
Worksheets(sourceSheet).Select

Set sourceRange = ActiveSheet.Rows("1:1")
Set destRange = Workbooks(destBook).Worksheets("Sheet1").Rows("1:1")
destRange.Value = sourceRange.Value

'change "A" to column with data in last row
Range("A" & Rows.Count).End(xlUp).Select
Set sourceRange = ActiveSheet.Rows(ActiveCell.Row & ":" & ActiveCell.Row)
Set destRange = Workbooks(destBook).Worksheets("Sheet1").Rows("2:2")
destRange.Value = sourceRange.Value
Set sourceRange = Nothing
Set destRange = Nothing

End Sub

 

[urkec]

I made some changes to your code that save the new workbook to the current
user's desktop with the name 'Copreco Reading'

Sub ExportCoprecoReadingData()
Const sourceSheet = "Site Reading Log" ' source
Dim sourceBook As String
Dim destBook As String
Dim sourceRange As Range
Dim destRange As Range

Application.ScreenUpdating = False
sourceBook = ThisWorkbook.Name
'get the new workbook object
Set sbFile = Workbooks.Add ' create new book
destBook = ActiveWorkbook.Name
Windows(sourceBook).Activate
Worksheets(sourceSheet).Select

Set sourceRange = ActiveSheet.Rows("1:1")
Set destRange = Workbooks(destBook).Worksheets("Sheet1").Rows("1:1")
destRange.Value = sourceRange.Value

'change "A" to column with data in last row
Range("A" & Rows.Count).End(xlUp).Select
Set sourceRange = ActiveSheet.Rows(ActiveCell.Row & ":" & ActiveCell.Row)
Set destRange = Workbooks(destBook).Worksheets("Sheet1").Rows("2:2")
destRange.Value = sourceRange.Value
Set sourceRange = Nothing
Set destRange = Nothing

'get the desktop path, save and close new workbook
Set WshShell = CreateObject("WScript.Shell")
sbFile.SaveAs Filename:=WshShell.SpecialFolders("Desktop") & "\Copreco
Reading.xls"
sbFile.Close

Set WshShell = Nothing
Set sbFile = Nothing

End Sub

 

[Carlee]

Hi there,

Thanks for the code. I put it into my workbook, but got a Runtime 1004
Error. It states 'the file could not be accessed'. The line in question is:

sbFile.SaveAs Filename:=WshShell.SpecialFolders("Desktop") & "\Copreco
Reading.xlsx """

I am working off of Excel 2007; however, this workbook will be implemented
on Excel 2003

Sub ExportCoprecoReadingData()
Const sourceSheet = "Site Reading Log" ' source
Dim sourceBook As String
Dim destBook As String
Dim sourceRange As Range
Dim destRange As Range

Application.ScreenUpdating = False
sourceBook = ThisWorkbook.Name
'get the new workbook object
Set sbFile = Workbooks.Add ' create new book
destBook = ActiveWorkbook.Name
Windows(sourceBook).Activate
Worksheets(sourceSheet).Select

Set sourceRange = ActiveSheet.Rows("1:1")
Set destRange = Workbooks(destBook).Worksheets("Sheet1").Rows("1:1")
destRange.Value = sourceRange.Value

'change "A" to column with data in last row
Range("A" & Rows.Count).End(xlUp).Select
Set sourceRange = ActiveSheet.Rows(ActiveCell.Row & ":" & ActiveCell.Row)
Set destRange = Workbooks(destBook).Worksheets("Sheet1").Rows("2:2")
destRange.Value = sourceRange.Value
Set sourceRange = Nothing
Set destRange = Nothing

'get the desktop path, save and close new workbook
Set WshShell = CreateObject("WScript.Shell")
sbFile.SaveAs Filename:=WshShell.SpecialFolders("Desktop") & "\Copreco
Reading.xlsx """
sbFile.Close

Set WshShell = Nothing
Set sbFile = Nothing

End Sub

Here the entire code:

 

[urkec]

You can add line to output the file path before SaveAs, tu make sure it is
constructed properly:

MsgBox WshShell.SpecialFolders("Desktop") & "\Copreco Reading.xlsx "
sbFile.SaveAs Filename:=WshShell.SpecialFolders("Desktop") & "\Copreco
Reading.xlsx"

 

[Carlee]

thanks to everyone...the problem has been resolved.