Results 1 to 1 of 1

Thread: Copy Range and Paste it in Outlook

  1. #1

    Copy Range and Paste it in Outlook



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hello Gurus,

    The code below is to send personalised emails, i however want to include the range M3:M31 as part of the body of the email. i need assistance to modify the code below to copy and paste this range into outllook. thanks
    Code:
    Sub Send_Files()
    'Working in 2000-2010
        Dim OutApp As Object
        Dim OutMail As Object
        Dim sh As Worksheet
        Dim cell As Range, FileCell As Range, rng As Range
        Dim LValue As String
        
        LValue = Format(Date, "dd-mmm-yy", vbUseSystemDayOfWeek)
        
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Set sh = Sheets("Send Personal Email")
    
        Set OutApp = CreateObject("Outlook.Application")
    
        For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    
            'Enter the file names in the C:Z column in each row
            Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    If cell.Value Like "?*@?*.?*" And _
               Application.WorksheetFunction.CountA(rng) > 0 Then
                Set OutMail = OutApp.CreateItem(0)
    
                With OutMail
                    .To = cell.Value
                    .Subject = "Testfile as at " & LValue
                    .Body = "Hello " & cell.Offset(0, -1).Value & vbNewLine & "Please find attached our Weekly report for the week ending " & LValue & "." & _
                    " Please do not hesitate to contact me should if you have any questions or comments"
                    
                    For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                        If Trim(FileCell) <> "" Then
                            If Dir(FileCell.Value) <> "" Then
                                .Attachments.Add FileCell.Value
                            End If
                        End If
                    Next FileCell
                    .Display  'Or use Send
                End With
    
    Set OutMail = Nothing
            End If
        Next cell
    
        Set OutApp = Nothing
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End Sub
    Attached Files Attached Files
    Last edited by p45cal; 2018-02-22 at 08:13 PM.

Posting Permissions

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