Compare two cells in a column, if TRUE, then compare the two rows colymn by column

[ExcelSwede]

Hi all helpful people. First, sorry about my English. I hope you´ll understand anyway.

I have several long mailinglists in Excel. One list for a specific purpose or a specific occation. Each list can include several adresses which can occure in another list. I will try to copy one list at a time, paste them into the same sheet and let the purpose for the list show in a specifik column. Then I want a macro to do this job:

Sub
sort by emailadress (col A)
Compare row 1 with row 2; row 2 with row 3; row 3 with row 4; and so on....
If two cells are equal, then column by column compare purposes and make the two compared rows similar. After being similar, i can delete one of the rows.
When all e-mailadresses are compared, I have a list where an emailadress only occure once, and for each emailaderess I can sort a column for a purpose and then copy the adresses that belongs to the desired purpose.
Endsub

Voilá!!

Starting position - duplicates of adresses

Sorted list

Comparing (illustrated by green cells)

Make rows silmilare

Delete one of the similare rows

Find, compare, make similare and delete one of next couple
If an emailadress occures more then twice (like dog, horse and pig below) I suppose its easiest to loop the macro several times until there is no more find couples.

In the end there is a sorted list and each emailadress has been saved with all different purposes.

Now, perhaps I want to email all adresses that are marked with purpose No 2, so I simply sort by that column and then select the adresses, copy and paste into Outlook.

All ExcelGuru's out there. Can this dream of mine became true?

Big hug for a clever solution.
ExcelSwede

 

[ExcelSwede]

Hello Fluff.
The best try to understand that I can achieve
Greatful for your completion
ExcelSwede

Sub ExcelSwede()
    'instantiate variables
    Dim Ary As Variant, Nary As Variant
    Dim r As Long, c As Long, nr As Long
    'Select the email address column as an array
    Ary = Range("A1").CurrentRegion.Value2
    'Not sure what Nary entails
    ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   'Create a dictionary
    With CreateObject("scripting.dictionary")
        'loop through all email addresses one line at a time
        For r = 1 To UBound(Ary)
            'if email address does not alreay exist
            If Not .Exists(Ary(r, 1)) Then
                nr = nr + 1
                'add it with 'nr' as value
                .Add Ary(r, 1), nr
                'loop through all columns for the new dictionary entry
                For c = 1 To UBound(Ary, 2)
                    'if position (r, c) cntains an x, not sure what happens. Not sure why c=1 as starting position
                    If Ary(r, c) <> "" Then Nary(nr, c) = Ary(r, c)
                Next c
            'if email address already exists
            Else
                'loop trough all columns except first
                For c = 2 To UBound(Ary, 2)
                    'if (r, c) contains an x, not sure what happens
                    If Ary(r, c) <> "" Then Nary(.Item(Ary(r, 1)), c) = Ary(r, c)
                Next c
            End If
        Next r
    End With
    'clear cells from values
    Range("A1").CurrentRegion.ClearContents
    'resizes rows to the nr of unique email addresses in the dictionary, then not sure what happens
    Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
End Sub

 

[Fluff]

Ok does this help

Sub ExcelSwede()
    'instantiate variables
    Dim Ary As Variant, Nary As Variant
    Dim r As Long, c As Long, nr As Long
    'Select the email address column as an array - selects all the data not just column A
    Ary = Range("A1").CurrentRegion.Value2
    'Not sure what Nary entails - Resizes the Nary array to the same size as the Ary array
    ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   'Create a dictionary
    With CreateObject("scripting.dictionary")
        'loop through all email addresses one line at a time
        For r = 1 To UBound(Ary)
            'if email address does not alreay exist
            If Not .Exists(Ary(r, 1)) Then
                nr = nr + 1
                'add it with 'nr' as value - nr is the row in Nary that holds that email
                .Add Ary(r, 1), nr
                'loop through all columns for the new dictionary entry
                For c = 1 To UBound(Ary, 2)
                    'if position (r, c) is not blank adds that value to Nary including the email hence starting with c=1
                    If Ary(r, c) <> "" Then Nary(nr, c) = Ary(r, c)
                Next c
            'if email address already exists
            Else
                'loop trough all columns except first
                For c = 2 To UBound(Ary, 2)
                    'if (r, c) is not blank adds that to Nary on the same row as the email stored in the dictionary
                    If Ary(r, c) <> "" Then Nary(.Item(Ary(r, 1)), c) = Ary(r, c)
                Next c
            End If
        Next r
    End With
    'clear cells from values
    Range("A1").CurrentRegion.ClearContents
    'resizes rows to the nr of unique email addresses in the dictionary and copies the Nary array into those cells
    Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
End Sub

 

[ExcelSwede]

Great!
Thank you for your kindness.

 

[Fluff]

You already posted that in post#11 & I replied in post#12