Two Lists of Contacts within one sheet. Need help sorting to find duplicates/format

[Atlanta]

HI,

I have received very two lists of contact information that have been combined into one sheet as seen below. I have broken this down into a smaller sample size because each list contaions over 5,000 rows and 20 columns wide. My question is....

Is there a way to sort the list below by Last>First>State so that if there is a duplicate within list 1 and list 2 they would be within the same row side by side. If the contact is unique to only one of the list, the other list would insert a line in the opposite list. Im having a hard time wrapping my head around this concept and have been manually inserting lines and formatting these two lists to that they match up correctly. I have added the desired format below in picture two to give an example.

[/URL][/IMG]

Notice how in this Picture below....
If the contacts match up they will be side by side.
If the contacts have same First and Last, they are sorted by state.
If the contacts are unique, the corresponding row in the other list is populated with an inserted blank row.

[/URL][/IMG]


So, is there a way to do this through VBA, V-Lookup? Array? Macro? Any help on this would be high appreciated. I've been working on this project for over a month.

 

[hiker95]

Atlanta,

Welcome to the MrExcel forum.

1. What version of Excel, and, Windows are you using?

2. Are you using a PC or a Mac?


You are posting pictures/IMG's. This means that if this was a problem where one needed to use your data, anyone trying to help you would have to enter the data manually. That makes no sense and I doubt that you would get an answer.


I would like more information. Please see the Forum Use Guidelines in the following link:

http://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html


Or, you can post your workbook/worksheets to the following free site (sensitive data changed), and provide us with a link to your workbook:

https://dropbox.com

 

[Atlanta]

hiker95,

Thanks for the helpful tips.

Im on a PC, Excel 2013, Windows 7

Here is a dropbox link with to the Workbook.

https://www.dropbox.com/s/kal9q0pizyoy0h6/REQUEST FOR HELP.xlsx?dl=0

Thanks,

 

[hiker95]

Atlanta,

I have tried several approaches to solve your request, but, I am unable to find a solution.

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.

 

[mikerickson]

I think that this will do what you want.

Sub test()
    Dim ListSheet As Worksheet
    Dim rngList1 As Range, rngList2 As Range
    Dim First1 As Long, Last1 As Long, First2 As Long, Last2 As Long
    Dim workingRow As Long, maxRow As Long
    Dim Name1 As String, Name2 As String
    Dim ListColor As OLE_COLOR
    
    Set ListSheet = ThisWorkbook.Sheets("Received Format"): Rem adjust
    Set rngList1 = ListSheet.Range("A:H"): Rem adjust
    Set rngList2 = ListSheet.Range("I:P"): Rem adjust
    
    Rem get column numbers of first,last names of each list, relative to sheet
    With rngList1
        First1 = .Columns(.Columns.Count - 1).Column
        Last1 = .Columns(.Columns.Count).Column
    End With
    With rngList2
        First2 = .Columns(2).Column
        Last2 = .Columns(1).Column
    End With
    
    Application.ScreenUpdating = False
    Rem sort list1
    With Range(rngList1.Rows(1), ListSheet.Cells(Rows.Count, Last1).End(xlUp))
        maxRow = .Rows.Count
        .Sort key1:=ListSheet.Cells(rngList1.Row, Last1), order1:=xlAscending, key2:=ListSheet.Cells(rngList1.Row, First1), order2:=xlAscending, Header:=xlYes
        Set rngList1 = .Cells
    End With
    With Range(rngList2.Rows(1), ListSheet.Cells(Rows.Count, Last2).End(xlUp))
        maxRow = maxRow + .Rows.Count + 1
        .Sort key1:=ListSheet.Cells(rngList2.Row, Last2), order1:=xlAscending, key2:=ListSheet.Cells(rngList2.Row, First2), order2:=xlAscending, Header:=xlYes
        Set rngList2 = .Cells
    End With

    workingRow = rngList1.Row + 1
    
    Do
        With ListSheet
            Name1 = .Cells(workingRow, Last1) & ", " & .Cells(workingRow, First1)
            Name2 = .Cells(workingRow, Last2) & ", " & .Cells(workingRow, First2)
            
            If Name1 = ", " And Name2 = ", " Then
                Rem end of job
                workingRow = maxRow
            ElseIf (Name1 = ", ") Or (Name2 = ", ") Or (Name1 = Name2) Then
                Rem do nothing, next row
            ElseIf Name1 < Name2 Then
                Rem add row to list2
                Application.Intersect(rngList2.EntireColumn, .Rows(workingRow)).Insert shift:=xlDown
            Else
                Rem add row to list1
                Application.Intersect(rngList1.EntireColumn, .Rows(workingRow)).Insert shift:=xlDown
            End If
            workingRow = workingRow + 1
        End With
    Loop Until maxRow <= workingRow
    
    Rem fix formatting
    With Range(rngList1.Rows(1), ListSheet.Cells(Rows.Count, Last1).End(xlUp))
        With Range(.Cells, Range(rngList2.Rows(1), ListSheet.Cells(Rows.Count, Last2).End(xlUp)))
            
            With Application.Intersect(.EntireRow, rngList1.EntireColumn)
                .Interior.Color = .Cells(1, 1).Interior.Color
            End With
            With Application.Intersect(.EntireRow, rngList2.EntireColumn)
                .Interior.Color = .Cells(1, 1).Interior.Color
            End With
            .Offset(.Rows.Count, 0).Clear
        End With
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[hiker95]

mikerickson,

Nicely done - one for my archives.


mikerickson, Atlanta,

Based on the downloaded workbook, you may want to change the following line of code from this:

    Set ListSheet = ThisWorkbook.Sheets("Received Format"): Rem adjust

To this:

    Set ListSheet = ThisWorkbook.Sheets("Recieved Format"): Rem adjust

 

[Atlanta]

mikerickson,

Nicely done - one for my archives.


mikerickson, Atlanta,

Based on the downloaded workbook, you may want to change the following line of code from this:

    Set ListSheet = ThisWorkbook.Sheets("Received Format"): Rem adjust

To this:

    Set ListSheet = ThisWorkbook.Sheets("Recieved Format"): Rem adjust

Ha, hiker95 thank you for politely calling out my spelling error.

 

[Atlanta]

To hiker95 and Mikerickson,

Thank you both for helping me out. I have not yet tried this solution, but I will be sure to let you know how goes... The workbook I added to this thread was just a small sample of the workbook that I'm trying to format. I know i'll have a challenge ahead of me trying to reformat this code for that much larger workbook. I'll keep you guys updated on how it goes.

 

[mikerickson]

The only adjustment that you will need to make is to the three lines at the beginning of the routine for ListSheet, rngList1 and rngList2. You need to make sure that the worksheet mentioned "Received Format" and the columns A:H , I:P match your actual situation.

Or at least thats my hope.

 

[hiker95]

To hiker95 and Mikerickson,

Thank you both for helping me out. I have not yet tried this solution, but I will be sure to let you know how goes... The workbook I added to this thread was just a small sample of the workbook that I'm trying to format. I know i'll have a challenge ahead of me trying to reformat this code for that much larger workbook. I'll keep you guys updated on how it goes.

Atlanta,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.