+ Reply to Thread
Results 1 to 1 of 1

Copy only the words in cell not the entire cell

Hybrid View

  1. #1
    Forum Contributor
    Join Date
    02-12-2018
    Location
    Clearwater, FL
    MS-Off Ver
    MS 365
    Posts
    217

    Copy only the words in cell not the entire cell

    I have a macro that basically creates an email for me, however there are certain parts that I just want the work from the cell and not the entire cell. The following is the CBA code that I am using.
    Public Function findEmployeeEmail(employeeName As String) As String
    Dim wsE         As Worksheet
    Dim fRng        As Range
    Dim eRec        As Long
    Dim firstName   As String
    Dim surName     As String
    Set wsE = Worksheets("Employees")
    
    firstName = Application.Trim(Left(employeeName, InStr(1, employeeName, " ")))
    surName = Application.Trim(Replace(employeeName, firstName, " "))
    With wsE.Range("B:B")
        Set fRng = .Find(What:=surName, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
        If Not fRng Is Nothing Then
            eRec = fRng.Row
            Do
                If fRng.Offset(0, 1).Value = firstName Then
                    findEmployeeEmail = wsE.Cells(fRng.Row, "U").Value
                    Exit Function
                           End If
                Set fRng = .FindNext(fRng)
            Loop While Not fRng Is Nothing And fRng.Row <> eRec
        End If
    End With
    End Function
    
    Public Sub Mail_Sheet_Outlook_Body()
    'Working in Excel 2000-2016
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
        Dim strbody As String
        Dim A As String
        Dim B As String
        Dim C As String
        Dim D As String
        Dim E As String
        Dim F As String
            
        A = Range("F16")
        B = Range("F19")
        C = Range("F4")
        D = Range("F5")
        E = Range("F9")
        F = Range("F7")
    
            With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Set rng = Nothing
        Set rng = Sheets("TSA Request").Range("A4:F29")
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
        On Error Resume Next
        With OutMail
            .To = "Location's Email"
            .CC = "SSCServiceRequests@pods.com"
            .BCC = ""
            .Subject = "Bring Rental Agreement: " & Range("F4")
            .HTMLBody = "The Customer " & RangetoHTML(Sheets("TSA Request").Range("F19")) & "has requested for you to bring the rental agreement to sign at the time of Inital Delivery" & RangetoHTML(Sheets("TSA Request").Range("A16:F16")) & RangetoHTML(Sheets("TSA Request").Range("A19:F19")) & RangetoHTML(Sheets("TSA Request").Range("A4:F4")) & RangetoHTML(Sheets("TSA Request").Range("A5:F5")) & RangetoHTML(Sheets("TSA Request").Range("A9:F9")) & RangetoHTML(Sheets("TSA Request").Range("A7:F7"))
            .Display   'or use .Display
        End With
        On Error GoTo 0
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    End Sub
    
    
    Public 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
    In the body I want it to say "The Customer " & "NAME" & "has requested for you to bring the rental agreement" and then under that in the body I want the Ranges
    RangetoHTML(Sheets("TSA Request").Range("A16:F16")) & RangetoHTML(Sheets("TSA Request").Range("A19:F19")) & RangetoHTML(Sheets("TSA Request").Range("A4:F4")) & RangetoHTML(Sheets("TSA Request").Range("A5:F5")) & RangetoHTML(Sheets("TSA Request").Range("A9:F9")) & RangetoHTML(Sheets("TSA Request").Range("A7:F7"))

    The issue is when it creates the email, it puts an extra line below the info request to generate this email. I would like for the agent to click on "Bring Rental Agreement" hyperlink which currently opens an email template, but rather it generate this email for them. Any help would be greatly appreciated. i have also attached a copy of my workbook for any assistance that you can provide.
    Attached Files Attached Files

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Excel Formula to Copy Value/ Words into a Cell if Amount is Equal to Another Cell Value
    By arnel_10 in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 03-22-2017, 07:06 PM
  2. [SOLVED] keyword search - a macros to change font color for specific key words (not entire cell)
    By kingwhopper in forum Excel Programming / VBA / Macros
    Replies: 9
    Last Post: 05-10-2014, 12:25 PM
  3. [SOLVED] Macro copy entire row if any cell frm col A in sheet1 match any cell frm col A in sheet2
    By daillest319 in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 10-28-2013, 03:20 PM
  4. Find Words from an entire column in a cell
    By sra233 in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 07-31-2013, 11:41 PM
  5. Find Words from an entire column in a cell
    By sra233 in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 07-31-2013, 04:16 PM
  6. [SOLVED] Delete entire row if the cell has three 3 or two 2 letter words
    By plasma33 in forum Excel Programming / VBA / Macros
    Replies: 8
    Last Post: 10-21-2012, 08:23 PM
  7. Need to find a word in a cell, copy the entire cell and two adjacent columns on same row
    By hang_sandwich in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 08-01-2012, 11:16 AM

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1