Email range to attach

Give this a try.

Sub Email_Journal()
    Dim File As String, strBody As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    File = Environ$("temp") & ".xlsx"

    strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
        "Attached, please find Journal Entries to be printed" & vbNewLine & vbNewLine & _
            "Regards" & vbNewLine & vbNewLine & _
            "Howard"

    Sheets("Data").Range("Journals").Copy
    
    Workbooks.Add
    
    With ActiveWorkbook
        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
        .SaveAs Filename:=File, FileFormat:=51
        .Close savechanges:=False
    End With
    
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")
        .Subject = Sheets("Data").Range("a42")
        .body = strBody
        .Attachments.Add File
        .Display
     End With
     
    Kill File
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Thy such modification:

Sub Email_Journal()

  Dim File As String, strBody As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
File = Environ$("temp") & ".xlsx"

strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
        "Attached, please find Journal Entries to be printed" & vbNewLine & vbNewLine & _
            "Regards" & vbNewLine & vbNewLine & _
            "Howard"

    Set Rng = Nothing
   
    
    Sheets("Data").Range("Journals").Copy
    
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets(1).Name = "Data"
With ActiveWorkbook
   .SaveAs Filename:=File, FileFormat:=51
   .Close savechanges:=False
End With

DoEvents

With CreateObject("Outlook.Application").CreateItem(0)
   

    
           .To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")

            .Subject = Sheets("Data").Range("a42")
    .body = strBody
    .Attachments.Add File
    
    
DoEvents
    .Display
          
     End With
Kill File
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

DoEvents are probably not needed. but they shall not harm.
And probably at the end of the day you will replace .Display with .Send

You may need after Paste add also pasting special the width of the columns.

I think the problem source was re-using a code which was originaly developed for sending whole sheet as the attachment, to send only one named range.

I'm reading this with smartphone, so cannot test, but try:

ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues

Try with slightly modified filename like:

Sub Email_Journal()

Dim File As String, strBody As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
File = Environ$("temp") & "\theFile.xlsx"

strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
        "Attached, please find Journal Entries to be printed" & vbNewLine & vbNewLine & _
            "Regards" & vbNewLine & vbNewLine & _
            "Howard"

    Set Rng = Nothing
   
    
    Sheets("Data").Range("Journals").Copy
    
Workbooks.Add
ActiveSheet.Range("a1").PasteSpecial xlPasteValues
ActiveSheet.Range("a1").PasteSpecial xlPasteColumnWidths

Sheets(1).Name = "Data"
With ActiveWorkbook
   .SaveAs Filename:=File, FileFormat:=51
   .Close savechanges:=False
End With

DoEvents

With CreateObject("Outlook.Application").CreateItem(0)
   

    
           .To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")

            .Subject = Sheets("Data").Range("a42")
    .body = strBody
    .Attachments.Add File
    
    
DoEvents
    .Display
          
     End With
Kill File
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

File = Environ$("temp") & "\" & Sheets("Data").Range("A42") & ".xlsx"

Glad to hear that, and thanks for marking thread solved and for the reputation added

Hi Kaper


I have added code that allow the user to set the page break. I need it amended so that once the page breaks have been adjusted in page Preview the macro will continue

 Sub Email_Journal()

 Dim File As String, strBody As String, LR As Long
  TheFile = Sheets("data").Range("A42")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
File = Environ$("temp") & "\" & Sheets("Data").Range("A42") & ".xlsx"
strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
        "Attached, please find Journal Entries to be printed" & vbNewLine & vbNewLine & _
            "Regards" & vbNewLine & vbNewLine & _
            "Howard"

    Set Rng = Nothing
   
    
    Sheets("Data").Range("Journals").Copy
    
    Set rng = Nothing
   
    
   Sheets("Data").Range("Journals").Copy
    
Workbooks.Add
ActiveSheet.Range("a1").PasteSpecial xlPasteValues
ActiveSheet.Range("a1").PasteSpecial xlPasteFormats
ActiveSheet.Range("a1").PasteSpecial xlPasteColumnWidths

Sheets(1).Name = "Data"
  LR = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
With ActiveWorkbook
With ActiveSheet.PageSetup
.PrintGridlines = True
.PrintArea = "A2:E" & LR + 5
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = "&D&T"
.CenterHeader = "Stocking Interest Journals"
.Orientation = xlLandscape
.FitToPagesWide = 1
End With

Sheets(1).Select
    ActiveWindow.View = xlPageBreakPreview

   .SaveAs Filename:=File, FileFormat:=51
   .Close savechanges:=False
End With

DoEvents

With CreateObject("Outlook.Application").CreateItem(0)
   
  ActiveWindow.View = xlPageBreakPreview
    
           .To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")

            .Subject = Sheets("Data").Range("a42")
    .body = strBody
    .Attachments.Add File
    
    
DoEvents
    .Display
          
     End With
Kill File
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

It would be appreciated if you would kindly amend the code