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

ExcelSwede

New Member
Joined
Mar 9, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
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
1615319388828.png


Sorted list
1615319427928.png


Comparing (illustrated by green cells)
1615319510638.png


Make rows silmilare
1615319579842.png


Delete one of the similare rows
1615319660754.png


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.

1615319776496.png


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


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.
1615320413823.png


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

Big hug for a clever solution.
ExcelSwede
 

Attachments

  • 1615319135483.png
    1615319135483.png
    23.7 KB · Views: 4

ExcelSwede

New Member
Joined
Mar 9, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Hello Fluff.
The best try to understand that I can achieve
Greatful for your completion
ExcelSwede


VBA Code:
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
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
63,772
Office Version
  1. 365
Platform
  1. Windows
Ok does this help
VBA Code:
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
63,772
Office Version
  1. 365
Platform
  1. Windows
You already posted that in post#11 & I replied in post#12 ;)
 

Forum statistics

Threads
1,143,909
Messages
5,721,455
Members
422,363
Latest member
Bogus_Potatoes

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top