Data from other sheet to copy into email

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,259
Office Version
  1. 2010
Platform
  1. Windows
Hi wondering if you can help me please with the code in BOLD, i am trying to grab the data from 'Work Issue' sheet from A1 to I then down to last, but it doesnt seem to be grabbing it and pasting into my email, everything else works apart from the little bit of code in bold, please can you help me? thanks for your time

HTML: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    
        With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)


          aEmail.HTMLBody = "<html>******>" & _
                            "<p>Hi " & Me.TextBox35.Value & "</p>" & _
                            "<p>" & Me.TextBox33.Value & "</p>" & _
                            "<p>" & Me.TextBox17.Value & "</p>" & _
                            "<table border=""1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "<tr>" & _
                            "<th>Date:</th>" & _
                            "<td>" & Me.TextBox18.Text & "</td><td>" & Me.TextBox19.Text & "</td>" & _
                            "<td>" & Me.TextBox21.Text & "</td><td>" & Me.TextBox23.Text & "</td>" & _
                            "<td>" & Me.TextBox25.Text & "</td><td>" & Me.TextBox26.Text & "</td>" & _
                            "</tr>" & _
                "<tr>" & _
                            "<th>Area:</th>" & _
                            "<td>" & Me.TextBox9.Value & "</td><td>" & Me.TextBox20.Value & "</td>" & _
                            "<td>" & Me.TextBox22.Value & "</td><td>" & Me.TextBox24.Value & "</td>" & _
                            "<td>" & Me.TextBox29.Value & "</td><td>" & Me.TextBox30.Value & "</td>" & _
                            "</tr>" & _
                            "</table>" & _
                "<br><br><br><br><br><br>" & _
                "<p>Many Thanks</p>" & _
                "<p>Complex Team</p>" & _
                "</body></html>"


        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
        aEmail.Display
        
[code]
[/code]
       
Unload Me

End Sub
 
Sort by date Sort by votes

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Hi Good morning, i have done the alterations to the code as advised many thanks for your advise i just come up with an error on the snippet below in bold, the RangetoHTML i get an errror on can you advise please? i have also attached the whole code for your reference :) hope you can help?

HTML: 
aEmail.HTMLBody = StrBody & RangetoHTML(rngDataToEmail)

HTML: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    Dim StrBody As String
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    
       With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)


          StrBody = "<html>******>" & _
                            "<p>Hi " & Me.TextBox35.Value & "</p>" & _
                            "<p>" & Me.TextBox33.Value & "</p>" & _
                            "<p>" & Me.TextBox17.Value & "</p>" & _
                            "<table border=""1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "<tr>" & _
                            "<th>Date:</th>" & _
                            "<td>" & Me.TextBox18.Text & "</td><td>" & Me.TextBox19.Text & "</td>" & _
                            "<td>" & Me.TextBox21.Text & "</td><td>" & Me.TextBox23.Text & "</td>" & _
                            "<td>" & Me.TextBox25.Text & "</td><td>" & Me.TextBox26.Text & "</td>" & _
                            "</tr>" & _
                "<tr>" & _
                            "<th>Area:</th>" & _
                            "<td>" & Me.TextBox9.Value & "</td><td>" & Me.TextBox20.Value & "</td>" & _
                            "<td>" & Me.TextBox22.Value & "</td><td>" & Me.TextBox24.Value & "</td>" & _
                            "<td>" & Me.TextBox29.Value & "</td><td>" & Me.TextBox30.Value & "</td>" & _
                            "</tr>" & _
                            "</table>" & _
                "<br><br><br><br><br><br>" & _
                "<p>Many Thanks</p>" & _
                "<p>Complex Team</p>" & _
                "</body></html>"


        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
        aEmail.HTMLBody = StrBody & RangetoHTML(rngDataToEmail)
        aEmail.Display
Unload Me

End Sub
 
Upvote 0
hi i just noticed the highlighted bit didnt show in bold, but i get the error on the 'RangetoHTML' code part from the line below, hope you can help, and thanks again for your time.
HTML: 
aEmail.HTMLBody = StrBody & RangetoHTML(rngDataToEmail)
 
Upvote 0
Hi hope you can help me please with the error, i dont know what i am doing wrong and apprecaite all your help, i am still a beginner in VBA
 
Upvote 0
Hi,

step through your code using the F8 key.
When the highlight has passed the line Set rngDataToEmail = .Range("A:I" & .Range("A" & Rows.Count).End(xlUp).Row)
Hover over rngDataToEmail.
What does the tooltip say?

My guess is 'Empty'.
 
Last edited:
Upvote 0
Hi,

How the range is specified appears to be a problem.

I have only ever had to deal with the last row in one column so finding a range from 2 columns with unknown last rows is new to me.
You need to set a range for Column A to I in order to use RangetoHTML .
However you don't know the last row and it could be in either column. (You may know if one column is always longer but I don't)

My attempt came up with this. Find the last row in the 2 columns you want then get the maximum of the 2.

Code: 
        Set rngA = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
        LastRowA = rngA.Rows.Count
        
        Set rngI = Range(Range("I1"), Range("I" & Rows.Count).End(xlUp))
        LastRowI = rngI.Rows.Count
              
        LastRow = WorksheetFunction.Max(LastRowA, LastRowI)

However further searching and I found a post on this forum - here:
https://www.mrexcel.com/forum/excel...st-non-empty-row-number-multiple-columns.html

and used that as it is much less code. However I've no idea why a search for * comes up with the last row - Anyone?

Code: 
'Replace


With Sheets("Work Issue")
 Set rngDataToEmail = .Range("A:I" & .Range("A" & Rows.Count).End(xlUp).Row)
End With


'With This

LastRow = Sheets("Work Issue").Columns("A:I").Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set rngDataToEmail = Sheets("Work Issue").Range("A1:I" & LastRow)
 
Last edited:
Upvote 0
Hi good morning, thank you very much for all your help, i have pressed the F8 key for the error on the 'RangetoHTML' error and get a 'compile error: Sub or Fucntion not defined', please see my updated code below, any ideas at all please? thank you again for your response back yesterday.

HTML: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    Dim StrBody As String
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    
LastRow = Sheets("Work Issue").Columns("A:I").Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set rngDataToEmail = Sheets("Work Issue").Range("A1:I" & LastRow)
 
    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)


          StrBody = "<html>******>" & _
                            "<p>Hi " & Me.TextBox35.Value & "</p>" & _
                            "<p>" & Me.TextBox33.Value & "</p>" & _
                            "<p>" & Me.TextBox17.Value & "</p>" & _
                            "<table border=""1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "<tr>" & _
                            "<th>Date:</th>" & _
                            "<td>" & Me.TextBox18.Text & "</td><td>" & Me.TextBox19.Text & "</td>" & _
                            "<td>" & Me.TextBox21.Text & "</td><td>" & Me.TextBox23.Text & "</td>" & _
                            "<td>" & Me.TextBox25.Text & "</td><td>" & Me.TextBox26.Text & "</td>" & _
                            "</tr>" & _
                "<tr>" & _
                            "<th>Area:</th>" & _
                            "<td>" & Me.TextBox9.Value & "</td><td>" & Me.TextBox20.Value & "</td>" & _
                            "<td>" & Me.TextBox22.Value & "</td><td>" & Me.TextBox24.Value & "</td>" & _
                            "<td>" & Me.TextBox29.Value & "</td><td>" & Me.TextBox30.Value & "</td>" & _
                            "</tr>" & _
                            "</table>" & _
                "<br><br><br><br><br><br>" & _
                "<p>Many Thanks</p>" & _
                "<p>Complex Team</p>" & _
                "</body></html>"


        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
        aEmail.HTMLBody = StrBody & RangetoHTML(rngDataToEmail)
        aEmail.Display
Unload Me

End Sub
 
Upvote 0
See my post Jul 31st, 2018, 01:45 PM - previous page.
At the bottom of your sub paste the Function code for RangetoHTML
 
Upvote 0
Hi sorry i dont know what you mean regarding what i need to change in the code, i am fairly new to all this coding, what is the function code please?
 
Upvote 0
Hi

I mean I already posted the function code in the post of Jul 31st, 2018, 01:45 PM when the RangetoHTML function was introduced.

Here it is to save time:
Paste it in the same module as the macro after the End Sub.

So:

Sub()

- macro code

End Sub

Function ()

- function code

End Function

Code: 
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Email error on border code
Replies
5
Views
370
Patriot2879
P
P
  • Solved
Copy and cut from sheet 'Raised'
Replies
7
Views
416
Patriot2879
P
P
  • Solved
Compile error: method or data member not found
Replies
6
Views
546
Patriot2879
P
P
  • Question Question
Email Me. to label and text on two lines issues
Replies
1
Views
304
Micron
M
P
  • Question Question
putting a snippet of code from one to another somehow
Replies
5
Views
322
Patriot2879
P

Forum statistics

Threads
1,224,829
Messages
6,181,218
Members
453,024
Latest member
Wingit77

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