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

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub ExcelSwede()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To ubund(Ary), 1 To UBound(Ary, 2))
   
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, c)) Then
            nr = nr + 1
            For c = 1 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(nr, c) = Ary(r, c)
            Next c
         Else
            For c = 2 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(.Item(Ary(r, c)), c) = Ary(r, c)
            Next c
         End If
      Next r
   End With
   Range("A1").CurrentRegion.ClearContents
   Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
End Sub

 

[ExcelSwede]

Hi & welcome to MrExcel.
How about

Sub ExcelSwede()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
  
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To ubund(Ary), 1 To UBound(Ary, 2))
  
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, c)) Then
            nr = nr + 1
            For c = 1 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(nr, c) = Ary(r, c)
            Next c
         Else
            For c = 2 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(.Item(Ary(r, c)), c) = Ary(r, c)
            Next c
         End If
      Next r
   End With
   Range("A1").CurrentRegion.ClearContents
   Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
End Sub

Deeply impressed of your kindness. But unfortunatly, I got an error. Sorry about Swedish text i Msg-box, but sure you can figure it out. Looking forward to next try ExcelSwede

 

[Fluff]

That's a typo it should be Ubound

 

[ExcelSwede]

Deeply impressed of your kindness. But unfortunatly, I got an error. Sorry about Swedish text i Msg-box, but sure you can figure it out. Looking forward to next try ExcelSwede

View attachment 33936

Sorry, saw right now that it was a simple failure, just spelling.
But, when this was corrected, another failure occures. Says that "index is out of range". That is mauch harder for me to adjust.....

 

[Fluff]

I realised that there were a number of problems. Trying to do it in a hurry never pays.
Try this version

Sub ExcelSwede()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            For c = 1 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(nr, c) = Ary(r, c)
            Next c
         Else
            For c = 2 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(.Item(Ary(r, 1)), c) = Ary(r, c)
            Next c
         End If
      Next r
   End With
   Range("A1").CurrentRegion.ClearContents
   Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
End Sub

 

[ExcelSwede]

I realised that there were a number of problems. Trying to do it in a hurry never pays.
Try this version

Sub ExcelSwede()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
  
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
  
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            For c = 1 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(nr, c) = Ary(r, c)
            Next c
         Else
            For c = 2 To UBound(Ary, 2)
               If Ary(r, c) <> "" Then Nary(.Item(Ary(r, 1)), c) = Ary(r, c)
            Next c
         End If
      Next r
   End With
   Range("A1").CurrentRegion.ClearContents
   Range("A1").Resize(nr, UBound(Nary, 2)).Value = Nary
End Sub

Deeply, deeeply, deeeeeply impressed. Fluff = Wizard of Excel!
Works absolutley perfect.
I joined this forum a few hours ago. Before, i've tried lots of ours without getting it solved. So greatful.
Now time has past midnight here in Sweden. Have to get some rest.
By the way, the only thing this code doesen't do, which I thought was necessary, is to sort data in column A in alphabetic order. How can it compare rows without first getting them sorted? For excellent performance, can you add a sorting in alphabetic order in column A?

sincerely
ExcelSwede

 

[Fluff]

I didn't see the point in sorting the data, as you said you would be sorting the data by different columns to get the emails you wanted.

 

[ExcelSwede]

Hello Fluff!
Again, thank you for the macro. I forgot my promise from the start of this thread.

So - Big hug

And after that, a new question - Is it possible to ask if you can make some comments in the macro? I have tried to understand how it works but I am not sure if I got it.

Two arrays, one i load the other if terms are as stipulated. Or?

Happy weekend!
ExcelSwede

 

[Fluff]

If you comment the code with what you think is happening & post it here, I will fill in the blanks & correct any misunderstandings.