How can I copy different sections of a sheet into a new sheet and send that as a mail.

Nikko · Dec 26, 2018

Hello everyone,

Hope everyone had a merry Christmas and are still in a good mood for the New Year

I put together a code, because I'm not a big light of VBA I have the principle Copy / Paste applied.
Try to insert in my code the desired areas I would like to copy, without much success.

So I ask you for your help with my plans.

How can I insert into my existing VBA code the desired areas I would like to copy and paste into the mail?

Example:
Would like to copy from an existing sheet area B1: C35 and area L1: S35 into a new sheet and send it by mail. Please see my VBA code I would like to insert this process into this code.

Sub Excel_Sheet_via_Outlook_JanEZL()
ActiveWorkbook.ActiveSheet.Unprotect ("s0nne")
Dim GruppenName, KasseMonat As String
GruppenName = ThisWorkbook.Sheets("DPV1").Range("A3")
KasseMonat = Month(CDate(ThisWorkbook.Sheets("DPV1").Range("A2"))) & "/" & Year(CDate(ThisWorkbook.Sheets("DPV1").Range("A2")))
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String
SavePath = Environ("TEMP")
Worksheets("DPV1").Copy
' Worksheets("DPV1").Range("B1:C35; L1:S35").Copy
'Range("A3:AJ60").Select
' Selection.Copy
ActiveSheet.UsedRange.Copy
ActiveSheet.Cells().PasteSpecial xlPasteValues
Application.Workbooks(Application.Workbooks.Count).SaveAs ThisWorkbook.Path & "" & "Dienstplanung" & "_" & GruppenName & "_" & Format(Now, "ddmmyyyy__hhmm") & ".xlsx"
With Application.Workbooks(Workbooks.Count)
AWS = .FullName
.Close
End With
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = "My.Kollegen@mail.de"
.Subject = "Dienstplanung - Gruppe: " & GruppenName & " - Monat: " & KasseMonat & " - " & Date & "-" & Time
.Attachments.Add AWS
.Body = "Hallo Kollegen," & vbCrLf & vbCrLf & "Im Anhang dieser E-Mail befindet sich deine Dienstplanung in Form einer Excel Datei." & vbCrLf & "Die Datei wird automatisch generiert, bitte beim Aufmachen der Datei alle Vormeldungen zu akzeptieren/aktivieren oder/und auf Weiter zu Drücken." & vbCrLf & vbCrLf & "Zu öffnen mit dem MS Excel Programm oder einem Excel kompatiblen Programm." & vbCrLf & vbCrLf & vbCrLf & "Vielen Dank," & vbCrLf & GruppenName & ""
.GetInspector
.Display
'.Send
Kill AWS
End With
'MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
ActiveWorkbook.ActiveSheet.Protect ("s0nne")
End Sub

Thx all in Advance

Nikko

Logit · Dec 26, 2018

.
Hopefully this example will help ?

Code:

Option Explicit


'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")  '<<-- edit sheet name as required
    ws1.Range("B1:C35", "L1:S35").Copy
    Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String


Dim xPath As String
Dim xWs  As String


xPath = Application.ActiveWorkbook.Path


Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Sheet1").Range("B1:C35", "L1:S35")  '<<----- edit range as required


If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If


'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"


    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With


On Error GoTo 0


'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With


Set OutMail = Nothing
Set OutApp = Nothing


End Sub


''<<<>>> There is no need to edit anything in this Function.


Function RangetoHTML(rng As Range)
    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

ncrcnbl · Dec 26, 2018

I made minor changes to what you had;

Code:

Sub Excel_Sheet_via_Outlook_JanEZL()
    Dim GruppenName, KasseMonat As String
    Dim wkbkSource As Workbook, wkbkNew As Workbook
    Dim MyMessage As Object, MyOutApp As Object
    Dim SavePath As String
    Dim AWS As String

    Set wkbkSource = ThisWorkbook
    GruppenName = wkbkSource.Sheets("DPV1").Range("A3")
    KasseMonat = Month(CDate(ThisWorkbook.Sheets("DPV1").Range("A2"))) & "/" & Year(CDate(ThisWorkbook.Sheets("DPV1").Range("A2")))


'    ActiveWorkbook.ActiveSheet.Unprotect ("s0nne")

    'Worksheets("DPV1").Copy

    Set wkbkNew = Workbooks.Add
    SavePath = Environ("TEMP")
    wkbkNew.SaveAs SavePath & "\" & "Dienstplanung" & "_" & GruppenName & "_" & Format(Now, "ddmmyyyy__hhmm") & ".xlsx"
'Range("A3:AJ60").Select
' Selection.Copy
'ActiveSheet.UsedRange.Copy
    wkbkSource.Worksheets("DPV1").Range("B1:C35, L1:S35").Copy
    wkbkNew.Sheets(1).Cells().PasteSpecial xlPasteValues
    
    'Application.Workbooks(Application.Workbooks.Count).SaveAs
    'With Application.Workbooks(Workbooks.Count)
    AWS = wkbkNew.FullName
    wkbkNew.Close SaveChanges:=True
    'End With
    Set MyOutApp = CreateObject("Outlook.Application")
    Set MyMessage = MyOutApp.CreateItem(0)
    With MyMessage

    .To = "My.Kollegen@mail.de"
    .Subject = "Dienstplanung - Gruppe: " & GruppenName & " - Monat: " & KasseMonat & " - " & Date & "-" & Time
    .Attachments.Add AWS
    .Body = "Hallo Kollegen," & vbCrLf & vbCrLf & "Im Anhang dieser E-Mail befindet sich deine Dienstplanung in Form einer Excel Datei." & vbCrLf & "Die Datei wird automatisch generiert, bitte beim Aufmachen der Datei alle Vormeldungen zu akzeptieren/aktivieren oder/und auf Weiter zu Drücken." & vbCrLf & vbCrLf & "Zu öffnen mit dem MS Excel Programm oder einem Excel kompatiblen Programm." & vbCrLf & vbCrLf & vbCrLf & "Vielen Dank," & vbCrLf & GruppenName & ""
    '.GetInspector
    .Display
    '.Send
    Kill AWS
End With
'MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
Set wkbkNew = Nothing
Set wkbkSource = Nothing

    'ActiveWorkbook.ActiveSheet.Protect ("s0nne")
End Sub

Nikko · Dec 26, 2018

Hi ncrcnbl,

Many thanks for your effort

,

I inserted it into a module and shows me error / stop at the line

wkbkSource.Worksheets ("DPV1"). Range ("B1: C35, L1: S35"). Copy

Maybe an idea why this may be?

Thx
Nikko

Nikko · Dec 26, 2018

Hi Logit,

your code give me a syntaxerror in

Text above Excel cells" & "" & _
RangetoHTML(rng) & "" & _
"Text below Excel cells.
"
I would like to thank you too for your effort, it is certainly very difficult to read the codes of beginners and above all understand what the beginner wants to do

Thx
Nikko

Logit · Dec 26, 2018

.
My apologies .. the code posted incorrectly.

Change that line to this :

Code:

.HTMLBody = "Text above Excel cells" & "" & _
                RangetoHTML(rng) & "" & _
                "Text below Excel cells.

Nikko · Dec 26, 2018

Logit, Thank you it works.

But it also copies the cells D to K, which I really did not want to duplicate. Just want to copy the range of B1: C35 and L1: S35.

Thx again

Nikko

Logit · Dec 26, 2018

.
There are two locations in the code where the range is referred to. Change that portion of the code to this :

Code:

Range("B1:C35, L1:S35")

Nikko · Dec 27, 2018

Hi Logit,

It has already been entered in the code, but it still shows the columns D to K in the mail.

Option Explicit

'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("DPV1") '<<-- edit sheet name as required
ws1.Range("B1:C35", "L1:S35").Copy
Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String

Dim xPath As String
Dim xWs As String

xPath = Application.ActiveWorkbook.Path

Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("DPV1").Range("B1:C35", "L1:S35") '<<----- edit range as required

If rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If

'Turn off screen updating to prevent flickering / flashing
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = "Your email address here in quotes"
.CC = ""
.BCC = ""
.Subject = "Summary Data"

.HTMLBody = "Text above Excel cells" & "" & _
RangetoHTML(rng) & "" & _
"Text below Excel cells."

' In place of the following statement, you can use ".Send" to
' Send the e-mail message.
.Display
End With

On Error GoTo 0

'Turn on screen updating
With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

''<<<>>> There is no need to edit anything in this Function.

Function RangetoHTML(rng As Range)
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 xublishsource=", _
"align=left xublishsource=")
'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

Logit · Dec 29, 2018

.
This is the entire code used here. No other code is included in the workbook I have here. The macros function as you desire.

Code:

Option Explicit


'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")  '<<-- edit sheet name as required
    ws1.Range("B1:C35, L1:S35").Copy
    Mail_Selection_Range_Outlook_Body
End Sub




Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String




Dim xPath As String
Dim xWs  As String




xPath = Application.ActiveWorkbook.Path




Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Sheet1").Range("B1:C35, L1:S35")  '<<----- edit range as required




If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If




'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With




Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)




With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"




    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With




On Error GoTo 0




'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With




Set OutMail = Nothing
Set OutApp = Nothing




End Sub




''<<<>>> There is no need to edit anything in this Function.




Function RangetoHTML(rng As Range)
    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

How can I copy different sections of a sheet into a new sheet and send that as a mail.

Nikko

Board Regular

Excel Facts

Logit

Well-known Member

ncrcnbl

New Member

Nikko

Board Regular

Nikko

Board Regular

Logit

Well-known Member

Nikko

Board Regular

Logit

Well-known Member

Nikko

Board Regular

Logit

Well-known Member

Similar threads

Forum statistics

Share this page

How can I copy different sections of a sheet into a new sheet and send that as a mail.

Board Regular

Excel Facts

Well-known Member

New Member

Board Regular

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock