My Table created by VBA

[Eric Penfold]

The code works fine except for the Table created by VBA does not appear on the Email??

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

 

[Candyman8019]

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.

 

[Eric Penfold]

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.

I have tied this still no luck I`m afraid

 

[Candyman8019]

I noticed that you have another thread where you're struggling with dates/times...https://www.mrexcel.com/board/threads/this-code-is-trying-to-delete-all-times-from-cells-so-just-show-s-date.1247726/

I wonder if there is something odd with your O365 install. A couple of things I would like you to try:

1. Are you able to try this sheet on another computer?
2. Create a fresh workbook. Manually enter 2 or 3 lines of data (not copy/paste). Copy this sub as you have it to the new workbook and see if it runs correctly.

 

[Eric Penfold]

Very sorry to waste your time i had a module named Format so the code didn`t recognize the Format Variable. Now working fine.

 

[Candyman8019]

Right on. Glad it’s sorted.