My Table created by VBA

E

Eric Penfold

Active Member
Joined
Nov 19, 2021
Messages
431
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
The code works fine except for the Table created by VBA does not appear on the Email??

VBA Code: 
Private Sub POEmailStaff()

    Dim wb     As Workbook
    Dim ws     As Worksheet
    Dim pwb    As Workbook
    Dim pws    As Worksheet
    Dim LRow   As Long
    Dim Rng    As Range
    Dim strTable As String
    Dim strStaffEmails As String
    Dim FormatRuleInput As String
    Dim i      As Integer
    Dim intNumRows As Integer
    Dim intRow As Integer
    Dim EmailApp As Object
    Dim EmailItem As Object
    Dim xMailbody As Object

    Set wb = ActiveWorkbook
    Set ws = wb.Sheets("Sheet")
    Set pwb = Workbooks("MyPersonal.xlsb")
    Set pws = pwb.Sheets("Emails")
    LRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set EmailApp = CreateObject("Outlook.Application")
    Set EmailItem = EmailApp.CreateItem(0)
   
    On Error Resume Next
    Set Rng = Application.InputBox( _
         Title:="EmailRange", _
         Prompt:="Select Range to Email", _
         Type:=8)
    If Rng Is Nothing Then Exit Sub
    On Error GoTo 0
   
    On Error Resume Next
    intNumRows = Rng.Rows.Count
   
    strTable = "<table border=1>"
    strTable = strTable & "<tr>"
    strTable = strTable & "<th>Entered By</th><th>Supplier Code</th><th>Supplier Name</th><th>Branch</th><th>Due Date</th><th>Notes</th><th>Net Amount</th></tr>"
   
    For intRow = 1 To intNumRows
        strTable = strTable & "<tr>"
        strTable = strTable & "<td>" & Rng(intRow, 1).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 2).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 3).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 4).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 5).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 6).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 7).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 8).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 9).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 10).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 11).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 12).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 13).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 14).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 15).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 16).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 17).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 18).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 19).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 20).Value & "</td>"
        strTable = strTable & "<tr>"
    Next
   
    strTable = strTable & "</table>"
   
    strStaffEmails = Application.WorksheetFunction.VLookup(Me.Staff_Names.Text, pws.Range("A2:B" & LRow), 2, 0)
   
   
    Select Case Time
        Case Is < TimeValue("12:00:00")
            xMailbody = "Good Morning"
        Case Is < TimeValue("17:00:00")
            xMailbody = "Good Afternoon"
    End Select
   
    With EmailItem
       
        If Me.Staff_Names = "NJ" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you confirm these in if we have received it?" _
                      & "<br><br> Or move the due date if not accurate</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
           
        ElseIf Me.Staff_Names = "TJ" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look and update/supply </p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
           
        ElseIf Me.Staff_Names = "TB" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look at these Pos and update the due date/supply as needed. Thank you </p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
           
        ElseIf Me.Staff_Names = "PMc" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look at these POs and update/supply if necessary. thanks</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
           
        ElseIf Me.Staff_Names = "LJK" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look at these Pos and update the due date/supply as needed. Thank you</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
           
        ElseIf Me.Staff_Names = "JH" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look and update/supply these Pos</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
        End If
       
    End With

End Sub
 
Sort by date Sort by votes

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
1698412669602.png


VBA Code: 
Private Sub POEmailStaff()

    Dim wb     As Workbook
    Dim ws     As Worksheet
    Dim pwb    As Workbook
    Dim pws    As Worksheet
    Dim LRow   As Long
    Dim Rng    As Range
    Dim strTable As String
    Dim strStaffEmails As String
    Dim FormatRuleInput As String
    Dim intNumRows As Integer
    Dim intRow As Integer
    Dim EmailApp As Object
    Dim EmailItem As Object
    Dim xMailbody As String

    Set wb = ActiveWorkbook
    Set ws = wb.Sheets("Sheet")
    Set pwb = Workbooks("MyPersonal.xlsb")
    Set pws = pwb.Sheets("Emails")
    LRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set EmailApp = CreateObject("Outlook.Application")
    Set EmailItem = EmailApp.CreateItem(0)
    
    On Error Resume Next
    Set Rng = Application.InputBox( _
         Title:="EmailRange", _
         Prompt:="Select Range to Email", _
         Type:=8)
    If Rng Is Nothing Then Exit Sub
    On Error GoTo 0
    
    On Error Resume Next
    intNumRows = Rng.Rows.Count
    
    strTable = "<table border=1>"
    strTable = strTable & "<tr>"
    strTable = strTable & "<th>Entered By</th><th>Supplier Code</th><th>Supplier Name</th><th>Branch</th><th>Number</th><th>Due Date</th><th>Notes</th><th>Net Amount</th></tr>"
    
    For intRow = 1 To intNumRows
        strTable = strTable & "<tr>"
        strTable = strTable & "<td>" & Rng(intRow, 1).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 2).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 3).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 4).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 5).Value & "</td>"
        strTable = strTable & "<td>" & Format(Rng(intRow, 6).Value, "mm/dd/yyyy") & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 7).Value & "</td>"
        strTable = strTable & "<td>" & Rng(intRow, 8).Value & "</td>"
        strTable = strTable & "<tr>"
    Next
    
    strTable = strTable & "</table>"
    
    strStaffEmails = Application.WorksheetFunction.VLookup(Me.Staff_Names.Text, pws.Range("A2:B" & LRow), 2, 0)
    
    
    Select Case Time
        Case Is < TimeValue("12:00:00")
            xMailbody = "Good Morning"
        Case Is < TimeValue("17:00:00")
            xMailbody = "Good Afternoon"
    End Select
    
    With EmailItem
        
        If Me.Staff_Names = "NJ" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you confirm these in if we have received it?" _
                      & "<br><br> Or move the due date if not accurate</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
            
        ElseIf Me.Staff_Names = "TJ" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look and update/supply </p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
            
        ElseIf Me.Staff_Names = "TB" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look at these Pos and update the due date/supply as needed. Thank you </p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
            
        ElseIf Me.Staff_Names = "PMc" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look at these POs and update/supply if necessary. thanks</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
            
        ElseIf Me.Staff_Names = "LJK" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look at these Pos and update the due date/supply as needed. Thank you</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
            
        ElseIf Me.Staff_Names = "JH" Then
            .To = strStaffEmails
            .CC = "Purchase@drainfast.co.uk"
            .Subject = "Over Heads Report Query"
            .HTMLBody = xMailbody & "," & " <p> Can you have a look and update/supply these Pos</p> " & "<p>" & strTable & "</p>" & _
                        "<br><br>Kind Regards,"
            EmailItem.Display
            Exit Sub
        End If
        
    End With
    
End Sub
 
Upvote 0
It looks like the current date format of your data is actually DD/MM/YYYY. Give that a try.
 
Upvote 0
Problem is I`ve tried that but it won`t change the value to just a date.
The cell shows a date but the time is shown when you look at the value on the formula bar. And it shows the time on the vba table.
 
Upvote 0
This shouldn't make a difference, but can you make sure that column is formatted as date...
1698413502726.png
 
Upvote 0
I'm sure you've probably tried this, but can you step through your code with F8 and confirm that it is failing on that particular line?
 
Upvote 0
I have tested this it looks fine when you change the format but thing is it still shows the date and time on on the formula bar & Excel Table.
 
Upvote 0
I wonder if it is confusing the format function with your variable 'Dim FormatRuleInput As String'
Can you try changing that to something that does not include the word 'format'. It will need to be changed throughout the sub.
 
Upvote 0
Candyman8019 said:
I'm sure you've probably tried this, but can you step through your code with F8 and confirm that it is failing on that particular line?
Click to expand...
It messes up on line
VBA Code: 
 strTable = strTable & "<td>" & Format(Rng(intRow, 6).Value, "mm/dd/yyyy") & "</td>"
On the word Format error = Expected variable or procedure, not module
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
My VLookup is not working
Replies
6
Views
472
Anthony47
A
P
  • Question Question
putting a snippet of code from one to another somehow
Replies
5
Views
304
Patriot2879
P
E
  • Solved
Change the font on Emails
2
Replies
11
Views
853
Eric Penfold
E
N
  • Question Question
VBA Code - add emails to outlook BCC from list (that updates)
Replies
1
Views
376
NormChart55
N
D
  • Question Question
VBA to Create Outlook Email Not Working for All Users
Replies
9
Views
311
Logit
Logit

Forum statistics

Threads
1,223,929
Messages
6,175,457
Members
452,643
Latest member
gjcase

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top