My Table created by VBA

E

Eric Penfold

Active Member
Joined
Nov 19, 2021
Messages
424
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

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
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
My VLookup is not working
Replies
6
Views
303
Anthony47
A
E
  • Solved
Change the font on Emails
2
Replies
11
Views
549
Eric Penfold
E
E
  • Question
This code is to put a excel range onto a email
Replies
3
Views
414
I_know_nuffin
I
D
  • Question
run macro on open
Replies
2
Views
120
deanop2
D
L
  • Question
Combining two codes by Using a Messagebox like Form with yes/no or alike
Replies
1
Views
125
lojanica
L

Forum statistics

Threads
1,215,110
Messages
6,123,140
Members
449,098
Latest member
Doanvanhieu

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