Help fixing a code for coping and emailing a pivot table in excel

J

Josh Johansen

This is the code I have written for a button to copy the active pivot table
and 7 cells above and then email. What I would like to be able to do is
instead of the email automatically going to [email protected], I would like there
to be an open email message where the user can select the subject and users
they would like to email it to. Also I am having a hard time figuring out
how to maintain the formatting in the copied and pasted sheet, it leaves me
with some cells full of #####. Any help would be awesome, thanks so much!

Private Sub CommandButton1_Click()
Dim rng As Range
Set rng = ActiveSheet.PivotTables(1).TableRange2
Set rng = Range(rng(1).Offset(-7, 0), rng)
Workbooks.Add Template:=xlWBATWorksheet
ActiveSheet.Range("A1").Select
rng.Copy
ActiveSheet.Range("A1").PasteSpecial xlValues
ActiveSheet.Range("A1").PasteSpecial xlFormats
ActiveWorkbook.SendMail Subject:="Scheduling", Recipients:="[email protected]"
ActiveWorkbook.Close SaveChanges:=False
End Sub
 
J

Jeff Hopper

The easiest solution would probably be to use the Outlook object model to
create/display the message. Do you have access to that? If so, and you need
some sample code, let me know...

Jeff Hopper
Hopper Consulting, Inc.
 
J

Josh Johansen

Hey Jeff, I am in the process of attempting to use some Outlook object model
with the help of Ron de Bruin, I am unfamiliar with VBA and I think I have
all the correct code, I just am not familiar enough to know where everything
has to be copied and pasted at. Here is what I have at the moment:

Private Sub Calendar1_Click()
ActiveCell.Value = CDbl(Calendar1.Value)
ActiveCell.NumberFormat = "mm/dd/yyy"
ActiveCell.Select
Calendar1.Visible = False
End Sub

Private Sub CommandButton1_Click()
Call Mail_Range
End Sub

Private Sub Worksheet_Selectionchange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("F3"), Target) Is Nothing Then
Calendar1.Left = Range("E1").Left
Calendar1.Top = Range("E1").Top
Calendar1.Visible = True
' select Today's date in the Calendar
Calendar1.Value = Date
ElseIf Calendar1.Visible Then Calendar1.Visible = False
End If
End Sub

Sub Mail_ActiveSheet()
'Working in 2000-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

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

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog
that you only
'see when you copy a sheet from a xlsm file with macro's
disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy
h-mm-ss")

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

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

The first and third sections are for a popup calander, I am trying different
things to get the rest of the code to work but I seem to be stuck. Thanks
for any help!
 
J

Jeff Hopper

That's quite a bit of code. Can you point out exactly where you're getting
"stuck" and what problems/errors you're encountering? Thanks...
 
J

Josh Johansen

Yeah I shouldn't have copied all of that code, I am sorry, I actually have
been able to get everything working how i want except that I want to figure
out how to copy it as text instead of copying the whole pivot table but I am
going to purpose a new question for that. Thanks for your help though.
 
Top