Save to Desktop, don't overwrite existing
 

I am using the below code to export the last row in the 'Site Reading Log' to
a new workbook on the desktop, named 'Copreco Daily Reading Submission'. It
works great, it overwrites the last file exported to the desktop, of the same
name.

Where is what i need this code to do:
1) export the last row of the Site Reading Log to a new workbook called
'Copreco Daily Submission"
2) save the new worksheet to the users desktop
3). if a file of the same name exists, allow the user to rename the sheet,
so as not to overwrite the existing one.


Sub ExportCoprecoReadingData()
'these have to do with THIS workbook
'name of the sheet to get data from
Const sourceSheet = "Site Reading Log"
'column that always have value in it in last row
Const sourceKeyColumn = "A"
'****
'This is the name you want to give to the
'NEW workbook created each time to put new data
'into as set up this code will overwrite any
'existing file of this name without any warning.
Const newWorkbookName = "Copreco Daily Reading Submission.xls"
'****

Dim sourceBook As String
Dim destBook As String
Dim sourceRange As Range
Dim destRange As Range
Dim MaxLastRow As Long
Dim pathToUserDesktop As String

'determine last possible row number
'based on version of Excel in use
If Val(Left(Application.Version, 2)) < 12 Then
'we are in pre-Excel 2007 version
MaxLastRow = Rows.Count
Else
'are in Excel 2007 (or later?)
MaxLastRow = Rows.CountLarge
End If
'keeps screen from flickering
'speeds things up also
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
Range(sourceKeyColumn & MaxLastRow).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 destRange = Nothing
Set sourceRange = Nothing
'build up the path to the user's desktop
'based on standard paths and Windows standards
'path is normally
' C:\Documents and Settings\username\Desktop
'our task is to determine the 'username' portion
'which is the Windows username (login name) which
'may be different than the Excel UserName

pathToUserDesktop = "C:\Documents and Settings\" & _
Get_Win_User_Name() & "\Desktop\" & newWorkbookName

'save new workbook, but don't nag
'user with "file exists" message
Application.DisplayAlerts = False
With Workbooks(destBook)
'renames it while saving it
'will overwrite existing file of same name
.SaveAs newWorkbookName
'close it
.Close
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
--
Carlee

Save to Desktop, don't overwrite existing
 

See comment inline


"Carlee" wrote in message
...
I am using the below code to export the last row in the 'Site Reading Log'
to
a new workbook on the desktop, named 'Copreco Daily Reading Submission'.
It
works great, it overwrites the last file exported to the desktop, of the
same
name.

Where is what i need this code to do:
1) export the last row of the Site Reading Log to a new workbook called
'Copreco Daily Submission"
2) save the new worksheet to the users desktop
3). if a file of the same name exists, allow the user to rename the sheet,
so as not to overwrite the existing one.


Sub ExportCoprecoReadingData()
'these have to do with THIS workbook
'name of the sheet to get data from
Const sourceSheet = "Site Reading Log"
'column that always have value in it in last row
Const sourceKeyColumn = "A"
'****
'This is the name you want to give to the
'NEW workbook created each time to put new data
'into as set up this code will overwrite any
'existing file of this name without any warning.
Const newWorkbookName = "Copreco Daily Reading Submission.xls"
'****

Dim sourceBook As String
Dim destBook As String
Dim sourceRange As Range
Dim destRange As Range
Dim MaxLastRow As Long
Dim pathToUserDesktop As String

'determine last possible row number
'based on version of Excel in use
If Val(Left(Application.Version, 2)) < 12 Then
'we are in pre-Excel 2007 version
MaxLastRow = Rows.Count
Else
'are in Excel 2007 (or later?)
MaxLastRow = Rows.CountLarge
End If
'keeps screen from flickering
'speeds things up also
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
Range(sourceKeyColumn & MaxLastRow).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 destRange = Nothing
Set sourceRange = Nothing
'build up the path to the user's desktop
'based on standard paths and Windows standards
'path is normally
' C:\Documents and Settings\username\Desktop
'our task is to determine the 'username' portion
'which is the Windows username (login name) which
'may be different than the Excel UserName

pathToUserDesktop = "C:\Documents and Settings\" & _
Get_Win_User_Name() & "\Desktop\" & newWorkbookName


Now that you got the file name - pathToUserDeskto - to SaveAs, you simple
verify if a file with that full name exists or not (you can use DIR()
function), if not exist, go ahead with code below, if exists, you could
either ask user to confirm the overwrite, or cancel the saving, or you could
pops up as File Save dialog box so uer can enter a file name to save.

You may also want to verify the user's desktop folder exists, in case the
"Get_Win_User_Name()" function returns a wrong user name (unless you 100%
sure the code is absolutely correct), so that the path to user's desktop is
incorrect.



'save new workbook, but don't nag
'user with "file exists" message
Application.DisplayAlerts = False
With Workbooks(destBook)
'renames it while saving it
'will overwrite existing file of same name
.SaveAs newWorkbookName

This is wrong, it may not save the file at user's desktop, because you did
not supply path, just file name. The file will be saved to whatever folder
that is current working folder Windows is set to. You should supply full
file name, like this:

.SaveAs pathToUserDesktop


'close it
.Close
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
--
Carlee