• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

(excel range to new mail) Loop and read range and copy those ranges into new email

Mr.Karr

Member
Hello

Can anyone please provide a code snippet to get the below requirement done.
Please refer to the attached file.

Sheets("Home") : User will feed worksheet name in columnF and columnG has the range to be copied.

The requirement is to recognize the worksheet name and go to the sheet, copy range and paste into the Metrics sheet. The same flow for the next available value under home sheet columnF & G.

Please this can be done by 2 ways;

1. We can either move all those ranges one by one directly into new email
2. Or utilize the "Metrics" sheet, paste those ranges as images one by one and export into new email at once (mail range into body of the email)

Please advise. Attached sample file for your reference.

Thanks in advance
K
 

Attachments

  • Sample file.xlsx
    15.7 KB · Views: 49
@Deepak : close enough. But I just need to add some loop to pick up values from home tab and paste into email one by one. Here I'm struck.

Can you pls help ?
 
Check this..

I haven't tested!!


Code:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim myrng As Range
    Dim r As Range

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
'  Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    With Sheets("Home")
        Set myrng = .Range("F2").CurrentRegion.Resize(Application.CountA(.Columns("F")) - 1, 1).Offset(1)
    End With

For Each r In myrng
    Set rng = Sheets(r.Value).Range(r.Offset(, 1))
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
'    On Error GoTo 0

'    If rng Is Nothing Then
'        MsgBox "The selection is not a range or the sheet is protected" & _
'              vbNewLine & "please correct and try again.", vbOKOnly
'        Exit Sub
'    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

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

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send  'or use .Display
    End With
    On Error GoTo 0
' do the some pause
Application.Wait Now + Time("00:00:01")
Next

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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
 
@Deepak : please note, the code snippet which you've provided above works but it is creating new email for each range but that is not the actual requirement.

Can we please modify it a bit to paste as range and copy paste one below another. Thanks in advance.
 
: please note, the code snippet which you've provided above works but it is creating new email for each range.

Yes!!

...but that is not the actual requirement
Can we please modify it a bit to paste as range and copy paste one below another.

Are u looking to paste all that ranges in a single mail following one by one.
 
yes thats's correct Deepak. Please help to paste all those ranges one by one as paste special Image format pls.

Optional: If that's complex! ? Probably we can utilize "Metrics" sheet where we can paste all those ranges one by one and export all at once ?

Pls help
 
tested!


Code:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
  Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim myrng As Range
    Dim r As Range

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
'  Set rng = Selection.SpecialCells(xlCellTypeVisible)
  'You can also use a fixed range if you want
    With Sheets("Home")
            Set myrng = .Range("F2").CurrentRegion.Resize(Application.CountA(.Columns("F")) - 1, 1).Offset(1)
    End With
   
    With Sheets("Metrics")
        .Cells.Clear
        For Each r In myrng
            Set rng = Sheets(r.Value).Range(r.Offset(, 1))
            rng.Copy .Range("A" & Application.CountA(.Columns(1)) + 1)
        Next
    Set rng = .UsedRange
    End With
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
'    On Error GoTo 0

'    If rng Is Nothing Then
'        MsgBox "The selection is not a range or the sheet is protected" & _
'              vbNewLine & "please correct and try again.", vbOKOnly
'        Exit Sub
'    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

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

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        '.Send  'or use .Display
        .Display
  End With
    On Error GoTo 0
' do the some pause

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
  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

Just need to add code to format the rng as u wish...
 
@Deepak : thank you very much. It works like a breeze.

One quick question: Between two pasted ranges, there is no empty line so I can enter some title or caption to explain about the below screenshot ( I can manually do but just that a line or two line gap needed, Pls if you can tweek it a bit
 
Ya sure.you can also put the header in sheets data from where they are get copied as i also noticed that these were without the header.
Another to put the some cells gap via VBA.
Depends on what u like.

For the second choice change it

Code:
Dim i as single,g as single

For Each r In myrng
i =1
g =2'gap
           Set rng = Sheets(r.Value).Range(r.Offset(, 1))
            rng.Copy .cells(i+g,1)
    i=i+rng.rows.count+g
       Next
 
sorry @Deepak the recent modification completely collapses the automation. It doesn't add any gap between ranges but pasting ranges next/right side of previous. But I expect it to paste one by one below with 2 or 3 enter gap.

pls refer the attached file. I'm sure this is so easy for you to figure it out.
 

Attachments

  • Sample file.xlsm
    33.1 KB · Views: 23
Sorry! Actually i typed the same on mobile thus a little mistake happen!!

Pls find revised

Code:
Dim i As Integer, g As Single
g = 2 'gap
i = 1
For Each r In myrng
    Set rng = Sheets(r.Value).Range(r.Offset(, 1))
        rng.Copy .Cells(i + g, 1)
    i = i + rng.Rows.Count + g
Next
 
@Deepak : Do you think is possible to paste as JPEG format or as picture ?
also, this copy paste doesn't keep the original view. Say, if I have few columns hidden between, it unhides & pastes it. Pls help
 
For visible cells changed this!!

Set rng = Sheets(r.Value).Range(r.Offset(, 1)).SpecialCells(xlCellTypeVisible)

For image check it.
 

Attachments

  • Sample file (1).xlsm
    32.2 KB · Views: 56
@Deepak : attached file works good. But the problem is it is getting pasted all as one. That makes no gap between 2 images. Can we paste one by one as image and give 2 row spaces between them.

Apologies if I'm demanding more. If you can help would be great
 
Back
Top