excel - Paste Pivot Table to Outlook email

I have code calling from Workbook A with dynamic values to form Workbook B file path, and trying to paste Workbook B pivot table to an email using Ron de Bruin's Function RangetoHTML.

It fails with

runtime error 9, Subscript out of range

Sub Send_email()

Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Dim source_file As String
Dim MAILBOX As String
Dim CC As String
Dim Rng As Range
Dim REASON As String

Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

source_file = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 15)
REASON = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 4)
MAILBOX = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 13)
CC = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 14)

With OutlookMail

  .BodyFormat = olFormatHTML
  .Display

   If REASON = "apple" Then
      source_file = "D:\User\OneDrive\123.xlsx"
      Set Rng = Nothing
      On Error Resume Next
      Set Rng = Workbooks(source_file).Worksheets("Summary").PivotTables(6).TableRange1
      .HTMLBody = "<BODY style='font-size:11pt;font-family:Calibri'>" & RangetoHTML(Rng) & .HTMLBody
    
   Else
      source_file = "D:\User\OneDrive\456.xlsx"
      Set Rng = Nothing
      On Error Resume Next
      Set Rng = Workbooks(source_file).Worksheets("Summary").PivotTables(6).TableRange1
      .HTMLBody = "<BODY style='font-size:11pt;font-family:Calibri'>" & RangetoHTML(Rng) & .HTMLBody

   End If

  .To = MAILBOX
  .CC = CC
  
End With
End Sub

I have code calling from Workbook A with dynamic values to form Workbook B file path, and trying to paste Workbook B pivot table to an email using Ron de Bruin's Function RangetoHTML.

It fails with

runtime error 9, Subscript out of range

Sub Send_email()

Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Dim source_file As String
Dim MAILBOX As String
Dim CC As String
Dim Rng As Range
Dim REASON As String

Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)

source_file = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 15)
REASON = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 4)
MAILBOX = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 13)
CC = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 14)

With OutlookMail

  .BodyFormat = olFormatHTML
  .Display

   If REASON = "apple" Then
      source_file = "D:\User\OneDrive\123.xlsx"
      Set Rng = Nothing
      On Error Resume Next
      Set Rng = Workbooks(source_file).Worksheets("Summary").PivotTables(6).TableRange1
      .HTMLBody = "<BODY style='font-size:11pt;font-family:Calibri'>" & RangetoHTML(Rng) & .HTMLBody
    
   Else
      source_file = "D:\User\OneDrive\456.xlsx"
      Set Rng = Nothing
      On Error Resume Next
      Set Rng = Workbooks(source_file).Worksheets("Summary").PivotTables(6).TableRange1
      .HTMLBody = "<BODY style='font-size:11pt;font-family:Calibri'>" & RangetoHTML(Rng) & .HTMLBody

   End If

  .To = MAILBOX
  .CC = CC
  
End With
End Sub

Share Improve this question edited Feb 3 at 14:12 CommunityBot 11 silver badge asked Jan 27 at 14:52 PUI Mr 1

Add a comment |

1 Answer 1

Sorted by: Reset to default 0

source_file is filename without the path. This assumes both your source workbooks are open.

Option Explicit

Sub Send_email()

    Const FOLDER = "D:\User\OneDrive\"
    
    Dim wb As Workbook, wbSrc As Workbook, wsSrc As Worksheet, rng As Range
    Dim source_file As String, r As Long
    Dim MAILBOX As String, CC As String, REASON As String
    
    Set wb = ThisWorkbook
    With wb.Worksheets("abc")
        .Activate
        r = ActiveCell.Row
        REASON = .Cells(r, "D")
        MAILBOX = .Cells(r, "M")
        CC = .Cells(r, "N")
    End With
    
    ' select source
    If REASON = "apple" Then
        source_file = "123.xlsx"
    Else
        source_file = "456.xlsx"
    End If
    'Debug.Print r, REASON, source_file
    
    ' select pivot table data
    Set wbSrc = Workbooks(source_file)
    ' use this if file not open
    'Set wbSrc = Workbooks.Open(FOLDER & source_file) 
    Set wsSrc = wbSrc.Sheets("Summary")
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = wsSrc.PivotTables(6).TableRange1
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "No pivot table data", vbCritical
        Exit Sub
    End If
    'Debug.Print rng.Address
    
    ' prepare email
    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    Set OutlookApp = New Outlook.Application
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)
    With OutlookMail
        .BodyFormat = olFormatHTML
        .Display
        .To = MAILBOX
        .CC = CC
        .HTMLBody = "<BODY style='font-size:11pt;font-family:Calibri'>" _
                    & RangetoHTML(rng) & .HTMLBody
    End With
    
End Sub

科技改变生活-雨落星辰 - 所有的伟大,都源于一个勇敢的开始

excel - Paste Pivot Table to Outlook email - Stack Overflow

1 Answer 1

与本文相关的文章

评论列表(0)