copy Excel range to Word and attach

[neveu]

Hello forum,

i would need your help with the following issue:

i want to make a loop to copy data from Excel to word and to attach the word document to outlook.

i already have a macro that copy data from excel to other excel files and attaches this to outlook email.


could you please help me to edit this so it would work with word?


here is the code i have:

Sub SendEmail()
With Application
     .ScreenUpdating = False
     .DisplayAlerts = False
     .EnableEvents = False
     
End With
Dim cell As Range
Dim DataRng As Range
Dim Header As Range
Dim TableData As Range
Dim sumRng As Range
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim counter As Integer
Dim CounterInvoices As Integer
Dim Outlook As Object  ' Outlook.Application
Dim OutlookMsg As Object  'Outlook.MailItem
Set Outlook = CreateObject("Outlook.Application")
On Error Resume Next
 With ActiveWorkbook.Sheets("Oracle")
  
 counter = .Cells(Rows.Count, "D").End(xlUp).Row
 Kcounter = .Cells(Rows.Count, "K").End(xlUp).Row
  
 End With
 
 'Sort in ascending order the values
 Columns("D:D").Select
    ActiveWorkbook.Worksheets("Oracle").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Oracle").Sort.SortFields.Add Key:=Range( _
        "D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Oracle").Sort
        .SetRange Range("A1:I" & counter)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
 Range("K:N").ClearContents
 Range("D1:D" & counter).AdvancedFilter xlFilterCopy, Range("K1:K" & counter), Range("K1"), Unique:=True
 
'Delete the top row
 Range("K1:N1").ClearContents
 
 Range("L2:L" & Kcounter).Select
 Selection.FormulaR1C1 = "=VLOOKUP(RC[-1],R2C4:R10000C9,6,0)"
 Selection.Copy
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   
 For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
 
 Set sumRng = Range("M1:M" & Cells(cell.Row, "M").Row - 1) 'change AD1 to AD2 if you have header row
 
 cell.Offset(0, 2).Value = Application.WorksheetFunction.CountIf(Range("D1:D" & counter), Cells(cell.Row, "K").Value)
 cell.Offset(0, 3).Value = Application.WorksheetFunction.Sum(sumRng) + 2
 cell.Offset(0, 4).Value = Cells(cell.Row, "M").Value + (Cells(cell.Row, "N").Value - 1)
  
 Set Rng = Range("A" & Cells(cell.Row, "N").Value & ":" & "H" & Cells(cell.Row, "O").Value)
 Set Header = Range("A1:H1")
 Set Data = Union(Header, Rng)
 
 Data.Select
 Set Source = Selection.Copy
 
 TempFilePath = Environ$("temp") & "\"
 
 TempFileName = "Payment number " & Cells(cell.Row, "D").Value
 
 Set wbk = ActiveWorkbook
 Set Dest = Workbooks.Add(xlWBATWorksheet)
 
 
 With Dest.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteValues
  .Cells(1).PasteSpecial Paste:=xlPasteFormats
  .Cells(1).Select
  Application.CutCopyMode = False
End With
 
 
 FileExtStr = ".doc": FileFormatNum = -4143
If Val(Application.Version) < 12 Then
        You are using Excel 2000 or 2003.
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        You are using Excel 2007 or 2010.
        FileExtStr = ".xlsx": FileFormatNum = 51
 End If
 
 Dest.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
 
 'Create the email message for each line from column A
 Set OutlookMsg = Outlook.CreateItem(olMailItem)
 With OutlookMsg
    ' set basic params
    .Subject = "Reminder: Invoices pending for approval for over 30 days"
    .HTMLBody = "Dear Sir/Madam, " & "<br><br>" & _
                "Currently there is a total of " & Cells(cell.Row, "AD").Value & " invoices on UCB Pharma SA/UCB SA either awaiting approval and coding or requiring a goods/service receipt. This is resulting in a very high volume of calls from unhappy suppliers which is not helping the business or our image." & "<br>" & _
                "Accounts Payable Department" & "<br>" & _
                "UCB Pharma SA & UCB SA Belgium" & "<br>"
    .Attachments.Add Dest.FullName
    '.SentOnBehalfOfName = "[EMAIL="ap.be@ucb.com"]ap.be@ucb.com[/EMAIL]"
    .To = cell.Offset(0, 1).Value
    '.ReplyRecipients.Add "[EMAIL="ap.be@ucb.com"]ap.be@ucb.com[/EMAIL]"
    .Display
            
End With

Dest.Close savechanges:=False
'Range("K:O").ClearContents
'Range("A1").Select
Next cell
End Sub

i have also found a macro that copies data from excel to word. maybe this will help. you need to activate the reference to word and outlook in VBA

 [FONT=Calibri]Sub CopyXLSDataToWorddoc()[/FONT]
[FONT=Calibri]' You must set a VBE reference to Microsoft Word Object Library first![/FONT]
[FONT=Calibri] [/FONT]
[FONT=Calibri]    Dim WordApp As Word.Application[/FONT]
[FONT=Calibri]    Dim WordDoc As Word.Document[/FONT]
[FONT=Calibri]   [/FONT]
[FONT=Calibri]    ' Create a Word document. To use a document that is already open[/FONT]
[FONT=Calibri]    ' use: Set WordApp = GetObject(, "Word.Application")[/FONT]
[FONT=Calibri]    Set WordApp = CreateObject("Word.Application")[/FONT]
[FONT=Calibri] [/FONT]
[FONT=Calibri]    ' Make the newly created Word instance visible[/FONT]
[FONT=Calibri]    WordApp.Visible = True[/FONT]
[FONT=Calibri]     [/FONT]
[FONT=Calibri]    ' Create a new document. To use the active document (if Word is open)[/FONT]
[FONT=Calibri]    ' use:  Set WordDoc = WordApp.ActiveDocument[/FONT]
[FONT=Calibri]    Set WordDoc = WordApp.Documents.Add[/FONT]
[FONT=Calibri]     [/FONT]
[FONT=Calibri]    ' Select your data to copy here, for example:[/FONT]
[FONT=Calibri]    Range("A1:A3").Copy[/FONT]
[FONT=Calibri]     [/FONT]
[FONT=Calibri]    ' Paste as unformatted text. For formatted text change[/FONT]
[FONT=Calibri]    ' wdPasteText to wdPasteRTF[/FONT]
[FONT=Calibri]    WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteText, _[/FONT]
[FONT=Calibri]     Placement:=wdInLine, DisplayAsIcon:=False[/FONT]
[FONT=Calibri]   [/FONT]
[FONT=Calibri]    ' Clean up[/FONT]
[FONT=Calibri]    Set WordDoc = Nothing[/FONT]
[FONT=Calibri]    Set WordApp = Nothing[/FONT]
[FONT=Calibri]End Sub[/FONT]