"For Each" Loop - Skipping Rows

[kmflynn]

Hello,

I have a for each loop that is pulling email addresses to set as recipients of emails. Thing is, it pulls emails "for each" clientCode - some clientCodes have multiple email addresses and thus have multiple rows. These emails need to have all email addresses as recipients and right now this loop is only addressing these to the first email address and skipping over the rest (if there are more than one).

i.e. )
client code email address
A 1@ex.com
A 2@ex.com
B 1@ex.com
B 2@ex.com

I bolded the examples that this loop adds as recipients, as you can see it is skipping email addresses for which there are multiple contacts for one client code. Can someone help me edit this to make sure it pulls all email addresses for which a client code is the same? Below is a piece of the VBA script I have.

    For Each rw In ThisWorkbook.Sheets("Client Contact Info").ListObjects("ClientContacts").ListRows
           'findrows for client code
            If ThisWorkbook.Sheets("Client Contact Info").Range("A" & rw.Range.Row).Value = clientCode Then
            'SetRecipients
                Recipients = Recipients & ThisWorkbook.Sheets("Client Contact Info").Range("B" & rw.Range.Row).Value & ";"
            End If
    Next rw

Thanks to all in advance.

Best,

-Kev

 

[michaelsmith559]

If you are wanting the email address for each unique client here is what I did:

Sheet 1 Setup:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Client Code	Email Address		Unique Client Code		Client Code	Email Address
2	A	1 at ex.com
3	A	2 at ex.com
4	B	1 at ex.com
5	B	2 at ex.com
6
Sheet1

Here is after macro runs:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Client Code	Email Address		Unique Client Code		Client Code	Email Address
2	A	1 at ex.com		A		A	1 at ex.com
3	A	2 at ex.com		B			2 at ex.com
4	B	1 at ex.com				B	1 at ex.com
5	B	2 at ex.com					2 at ex.com
6
Sheet1

Here is the macro:

Sub Client_Email_Addresses()
Application.ScreenUpdating = False
Dim i As Long, mylastrow As Long
Dim myval As String, lastcolumn As Long
Dim add1 As Long, add2 As Long
Dim xrow As Long, lastrow As Long

Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Range("D2")
Range("D2").Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.RemoveDuplicates Columns:=Array(1), Header:=xlNo
Selection.Sort key1:=ActiveCell, order1:=xlAscending

mylastrow = Cells(Rows.Count, 4).End(xlUp).Row

For i = 2 To mylastrow

myval = Cells(i, 4).Value
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = _
    Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious).Offset(0, -5).Column
add1 = Columns(1).Find(What:=myval, LookIn:=xlValues, LookAt:=xlWhole).Row
xrow = add1

Do

If Cells(xrow + 1, 1).Value <> myval Then
    add2 = xrow
    Exit Do
Else
    xrow = xrow + 1
End If

Loop Until xrow = lastrow + 1

Range(Cells(add1, lastcolumn), Cells(add2, lastcolumn)).Copy Cells(Rows.Count, 7).End(xlUp).Offset(1, 0)
Range(Cells(add1, 1), Cells(add1, 1)).Copy Cells(add1, 6)

Next

Range("C1").Select
Application.ScreenUpdating = True
End Sub

 

[michaelsmith559]

I forgot to mention that I am assuming your client names are sorted in ascending order. If not you will need to sort them for the macro to work.

 

[michaelsmith559]

This is the other way that I took your request:

Sheet 1 Setup:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Client Code	Email Address		Unique Email Address		Client Code	Email Address
2	A	1 at ex.com
3	A	2 at ex.com
4	B	1 at ex.com
5	B	2 at ex.com
6
Sheet1

After macro:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Client Code	Email Address		Unique Email Address		Client Code	Email Address
2	A	1 at ex.com		1 at ex.com		A	1 at ex.com
3	A	2 at ex.com		2 at ex.com		B
4	B	1 at ex.com				A	2 at ex.com
5	B	2 at ex.com				B
6
Sheet1

Macro:

Sub Client_Email_Addresses()
Application.ScreenUpdating = False
Dim i As Long, mylastrow As Long
Dim myval As String, lastcolumn As Long
Dim add1 As Long, add2 As Long
Dim xrow As Long, lastrow As Long

Range("B2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Range("D2")
Range("D2").Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.RemoveDuplicates Columns:=Array(1), Header:=xlNo
Selection.Sort key1:=ActiveCell, order1:=xlAscending

Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Select
Selection.Sort key1:=Range("B2"), order1:=xlAscending, Header:=xlGuess
Range("C1").Select

mylastrow = Cells(Rows.Count, 4).End(xlUp).Row

For i = 2 To mylastrow

myval = Cells(i, 4).Value
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = _
    Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious).Offset(0, -5).Column
add1 = Columns(2).Find(What:=myval, LookIn:=xlValues, LookAt:=xlWhole).Row
xrow = add1

Do

If Cells(xrow + 1, 2).Value <> myval Then
    add2 = xrow
    Exit Do
Else
    xrow = xrow + 1
End If

Loop Until xrow = lastrow + 1

Range(Cells(add1, lastcolumn - 1), Cells(add2, lastcolumn - 1)).Copy Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)
Range(Cells(add1, lastcolumn), Cells(add1, lastcolumn)).Copy Cells(add1, 7)

Next

Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Select
Selection.Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlGuess
Range("C1").Select
Application.ScreenUpdating = True
End Sub

 

[kmflynn]

Thanks a ton for your responses.

I am about to take a crack at this with your first interpretation and the macro which is exactly what I am looking for.

Will follow up on this, thanks again.