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]

You're missing a slash to close your table row in this line:

        strTable = strTable & "<tr>"

s/b

        strTable = strTable & "</tr>"

 

[Eric Penfold]

Yes i see that will now work thanks?
Also I have a load of columns tacked on the end. How do i get rid of them? Also the Date shows the Date & time I just want the date to show in column.

 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>"

 

[Candyman8019]

Which columns do you need. It looks like you have headers for 7 columns; however you have 20 table data fields. It's tough to determine without seeing your sheet and expected output. It is possible you only need the first 7 data elements, for example:

        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>"

 

[Eric Penfold]

Thanks! Now works a treat except for the Date also shows time how do you get rid of the time showing?

 

[Candyman8019]

Assuming the date is in your 5th element, you can try changing the line to this:

        strTable = strTable & "<td>" & Format(Rng(intRow, 5).Value, "mm/dd/yyyy") & "</td>"

 

[Eric Penfold]

I tried to use your line but doesn`t seem to like the Format.

 

[Candyman8019]

Is there actually a date in that field?

 

[Eric Penfold]

Yes their is

 

[Candyman8019]

What error message is it giving you?