Need to copy part of active spreadsheet and save to desktop

[bbking5]

Hi all,

I have been trying all morning to figure out how to amend existing code in a workbook that is used by many different users. I am working in Excel 2003. The existing code copies data from certain cells in the active worksheet (which is password protected) into a new worksheet and saves that new worksheet to a temp folder, sends it to a particular email address using outlook and closes it, returning the user to the first workbook. You will see that it also unhides then rehides columns of the first worksheet during this process so that the user never has to see them. Problem here is that none of the users are using outlook anymore and I would prefer that this new spreadsheet that is created just be saved to the users desktop. I have found bits and pieces of what I needed on the web, but I can't seem to put it all together (I usually end up being sent to the debugger just short of having the newly created spreadsheet saved to desktop). Here is the existing code:


Private Sub CommandButton1_Click()
Range("A2:G2").Select
Selection.ClearContents
Range("G8:G13").Select
Selection.ClearContents
Range("G15:G20").Select
Selection.ClearContents
Range("G22").Select
Selection.ClearContents
End Sub

Private Sub CommandButton2_Click()
'Working in 2000-2007
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim SubjectLine As String
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object

ActiveSheet.Unprotect Password:="researchorg1"
ActiveSheet.Columns("C").Hidden = False
ActiveSheet.Columns("F").Hidden = False
ActiveSheet.Columns("H:R").Hidden = False

Set Source = Nothing
On Error Resume Next
Set Source = Range("A6:R24").SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Survey Response Form - " & Range("A2") & " " & Range("B2")

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsx": FileFormatNum = 51
End If

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr
On Error Resume Next
With OutMail
.To = "???@???.com"
.CC = ""
.BCC = ""
.Subject = "Survey Response Form for " & Range("A2") & " " & Range("B2")

.Body = "The attached document is a survey response form for " & Range("A2") & " " & Range("B2") & "." & " " & "Please load this information into the master file."
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveSheet.Columns("C").Hidden = True
ActiveSheet.Columns("F").Hidden = True
ActiveSheet.Columns("H:R").Hidden = True
ActiveSheet.Protect Password:="researchorg1"
End Sub



Essentially what I need to do is circumvent the whole email bit and save the spreadsheet that is created to the users desktop instead of a temp folder.

Thanks for any help that anyone can provide.

[Kenneth Hobs]

Welcome to the forum! Please paste code between VBA code tags.

Here is one way to get the Desktop path:
[VBA]Msgbox CreateObject("WScript.Shell").SpecialFolders("Desktop")& Application.PathSeparator[/VBA]