Looping through Filter and then copying the data so I can paste or put into outlook body

Hi Josh

This Link explains how to do as you describe. If you need help adapting let me (us) know.

http://www.rondebruin.nl/win/s1/outlook/amail4.htm

Hello Josh,

No disrespect to John but I have never seen any code to do what you want. The attached workbook is an automated version of your original based on your requirements.

I have added a second sheet that contains a list of the reps and their email addresses. There is a button on this sheet that will send an email to each rep in the list after the first sheet is filtered by the rep's name.

You will need to change the subject line of the email macro "SendEmails" to what you want. It is highlighted in blue font. Here are the macros that have been added to the attached workbook.

Sub EmailFilteredRange(ByVal Recipient As String, ByVal Subject As String)

  ' Written: October 24, 2013
  ' Author:  Leith Ross
  ' Summary: Emails a filtered range in HTML format using Outlook.
    
    Dim Area     As Range
    Dim cnt      As Long
    Dim Data()   As Byte
    Dim HTMLcode As String
    Dim olApp    As Object
    Dim Rng      As Range
    Dim TempFile As String
    Dim Wks      As Worksheet
    
      ' Get all of the cells in the filter area.
        Set Rng = Sheet1.Range("A1").CurrentRegion
        
      ' Include the sub total row.
        Set Rng = Rng.Resize(Rng.Rows.Count + 2)
        
      ' Get cells only filtered cells and sub total row.
        Set Rng = Intersect(Rng, Sheet1.Cells.SpecialCells(xlCellTypeVisible))
    
          ' Copy the worksheet to create a new workbook.
            Sheet1.Copy
            Set Wks = ActiveSheet
            
          ' Turn off the AutoFilters.
            Wks.AutoFilterMode = False
        
          ' Clear the new worksheet except for the header row.
            Wks.UsedRange.Offset(1, 0).ClearContents
            
          ' Create a contiguous range on the new worksheet to be emailed.
            For Each Area In Rng.Areas
                Wks.Range("A1").Offset(cnt, 0).Resize(Area.Rows.Count, Area.Columns.Count).Value = Area.Value
                cnt = cnt + Area.Rows.Count
            Next Area
        
          ' This is the contiguous range of cells to email.
            Set Rng = Wks.Range("A1").CurrentRegion
            Set Rng = Rng.Resize(RowSize:=Rng.Rows.Count + 2)
            
              ' The new workbook will be saved to the user's Temp directoy
                TempFile = Environ("Temp") & "\" & Wks.Name & ".htm"
     
              ' If a file by this exists then delete it
                If Dir(TempFile) <> "" Then Kill TempFile
           
              ' Convert the new worksheet into an HTML file.
                With Wks.Parent.PublishObjects
                    .Add(SourceType:=xlSourceRange, _
                         Filename:=TempFile, Sheet:=Wks.Name, _
                         Source:=Rng.Address, HtmlType:=xlHtmlStatic) _
                    .Publish Create:=True
                End With
       
              ' Read the TempFile back as a byte array.
                Open TempFile For Binary Access Read As #1
                    ReDim Data(LOF(1))
                    Get #1, , Data
                Close #1
            
              ' Convert the byte array into a VBA string.
                HTMLcode = StrConv(Data, vbUnicode)
            
          ' Close the new workbook.
            Wks.Parent.Close SaveChanges:=False
          
          ' Change the HTML code to align the output on the left side of the page.
            HTMLcode = VBA.Replace(HTMLcode, "align=center x:publishsource=", "align=left x:publishsource=")
                      
      ' Start Outlook and send the email.
        Set olApp = CreateObject("Outlook.Application")
        olApp.Session.GetDefaultFolder (6)
        
        With olApp.CreateItem(0)
            .To = Recipient
            .Subject = Subject
            .BodyFormat = 2
            .HTMLBody = HTMLcode
            .Send
        End With

End Sub

Sub SendEmails()

    Dim Cell As Range
    Dim Rng As Range
    Dim Subj As String
    Dim Wks As Worksheet
    
      ' Change this to what you want the subject line to be.
        Subj = "This is subject line of the email."
        
        Set Wks = Sheet2
        Wks.AutoFilterMode = False
        
        Set Rng = Wks.Range("A2")
        LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
        If LastRow < Rng.Row Then Exit Sub
        
        Set Rng = Rng.Resize(RowSize:=LastRow - Rng.Row + 1)
        
            For Each Cell In Rng
                If Cell.Offset(0, 1) <> "" Then
                    Sheet1.AutoFilterMode = False
                    Sheet1.UsedRange.AutoFilter Field:=1, Criteria1:=Cell.Value, VisibleDropDown:=True
                    Call EmailFilteredRange(Cell.Offset(0, 1).Text, Subj)
                Else
                    MsgBox Cell & " has No Email Address.", vbExclamation
                End If
            Next Cell
        
End Sub

Hi Josh and Leith

I did give an incorrect Link to Josh but this Code by Ron Debruin does as Josh describes as his requirements.

Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range, cel As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim LR As Long

    Set rng = Nothing
    Set ws = Sheets("Sheet1")

    With ws
        If Not .AutoFilterMode Then
            .Range("A1").AutoFilter
        End If
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row

        For Each cel In Range("Names")
            .Range("A1:H" & LR).AutoFilter Field:=1, Criteria1:=cel

            On Error Resume Next
            'Only the visible cells in the selection
            Set rng = .Range("A1:H" & LR).SpecialCells(xlCellTypeVisible)
            'You can also use a range if you want
            '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)
                .Display
                '        .Send   'or use .Display
            End With
            On Error GoTo 0
        Next cel
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        .ShowAllData
    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-2010
    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

Hi Josh

I'll defer to Leith on this one...my point was that Code does exist on the Internet to do as you require (with modification).

Hello Josh,

Isn't the subtotal row simply "pushed" down when a new entry is made? If the answer is yes then you can format this row as you like,