Select Range based on list a looping list to send as an email

[JSuarez]

I'm looking to use a list in a column to loop through to select each qualifying range to email e.g.:

Column AC - AF and rows are selected according to the qualifier (Owner)/variable, when I run the script (Frankenstein) first loops is correct, but the second adds the the first plus the second selection, and so on. This is a sample of possible 200 entries, which would fluctuate progressively. I think the problem is at Sub SelectByCellValue. The code is rough, but I'm trying to keep notes for each step for now. Any help to get this correct and/or improved would be appreciated!

AC	AD	AE	AF		AO	AP
ID#	S/N	Alias	Owner		List	Email
UID1	S/N1	Alias1	Usr1		Usr1	Usr1@xxx.com
UID1	S/N2	Alias2	Usr1		Usr2	Usr2@xxx.com
UID1	S/N3	Alias3	Usr2		Usr3	Usr3@xxx.com

<tbody>
</tbody>

Sub SelectActiveList()
'https://www.wiseowl.co.uk/blog/s193/for-each-next.htm
'a reference to the first Muppet


Dim TopCell As Range


'references to:


'- the range of Muppets; and


'- each individual Muppet cell


'a reference to each cell in the muppet names column


Dim MuppetRange As Range


Dim MuppetCell As Range


'first check there is a top cell to start from


Set TopCell = Cells.Find("Active List")


If TopCell Is Nothing Then


MsgBox "Can not find top of column, where is Active List Header name?"


Exit Sub


End If


'get a reference to the column of muppets


Set MuppetRange = Range(TopCell.Offset(1, 0), TopCell.End(xlDown))


'now look at each muppet in turn in this block


For Each MuppetCell In MuppetRange


'if this has rating more than 5 in column D ...


If IsEmpty(MuppetCell) = False Then


'colour entire row blue


'Range(MuppetCell, MuppetCell.End(xlToRight)).Interior.ColorIndex = 20








'Sub SelectByCellValue()
'UpdatebyExtendoffice20161128
    Dim LastRow As Long
    Dim xRg As Range, yRg As Range
    'change Sheet1 to suit
    With ThisWorkbook.Worksheets("Sheet1")
        LastRow = .Cells(.Rows.Count, "AG").End(xlUp).row
        Application.ScreenUpdating = False
        For Each xRg In .Range("AG1:AG" & LastRow)
            If UCase(xRg.text) = MuppetCell Then
                If yRg Is Nothing Then
                    Set yRg = .Range("AC" & xRg.row).Resize(, 5)
                Else
                    Set yRg = Union(yRg, .Range("AC" & xRg.row).Resize(, 5))
                End If
            End If
        Next xRg
        Application.ScreenUpdating = True
    End With
 
    If Not yRg Is Nothing Then yRg.Select
    
'End Sub


    If MsgBox("Is this correct! Are you sure?", vbYesNo) = vbNo Then Exit Sub








'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-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object


    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible) 'Orginal info.
    'Range("AC" & (ActiveCell.row), Selection).Resize(, 5).Select
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    
    
    'You can also use a fixed 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 = MuppetCell.Offset(0, 1).Value
        .CC = "x"
        .BCC = ""
        .Subject = "Lunch"
        .HTMLBody = "Hello" & RangetoHTML(rng)
        .Display   'or use .Display or .Send
    End With
    On Error GoTo 0


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


    Set OutMail = Nothing
    Set OutApp = Nothing
'End Sub


'rng = vbNullString












End If


Next MuppetCell


End Sub

 

[JSuarez]

Do I need to do anything to put back into que for further review or assistance?

 

[Logit]

.
Give it a day or two. If no additional responses, try "bumping" the post.

 

[JSuarez]

Bumping?

 

[Logit]

.
You are close. After a day or so, simply post another message indicating you are "bumping" the message back up to the top of the stack and
still looking for assistance.

When you post another message, the go to the main window of the FORUM you should see your post at the top of all the posts ... at least for awhile.

 

[JSuarez]

I am "bumping" the message back up to the top of the stack and
still looking for assistance.