Aligning rows of data in Excel via VBA

[Hu Rocan]

Hi all,
Perhaps someone can answer this question: I have rows of data in two lists in different columns in Excel. Both lists have keys for their indices, these keys are numeric and can only be from 1 to 999,999. One list has 18 columns including the key which is in column A (so the columns from List 1 are A to R inclusive); the other list has 16 columns including the key in column T (columns for the second list are T to AI inclusive). Column S between the lists is empty.
I would like to align the information in both lists that have the same key into the same rows. If this is to be done in the same worksheet, then the identified key would be in column AK, the info from the first list would go into columns AL to BD, column BE would be empty, and info from the second list for the same keys would go into columns BF to BU. Alternatively, this line-up of rows could go into a different worksheet, I have no preference.
FYI, while the first list has no duplication for numeric keys, the second list contains duplicates or multiple entries that are different for the same key. In the case of such duplication, I would like the program to only return the first entry in the aligned rows but mark the first empty cell in that row with "duplicate" if there are two instances of the key, "triplicate" if there are three instances, and "mult" if there are more than 3 instances, so I know what it is. If required, I can put the two lists in separate worksheets, and sort the lists by their numeric keys in ascending order. Keys - again - can be anything from 1 to 999,999. First list is roughly 24K rows, second list roughly 20K rows.
Many thanks.

 

[DanteAmor]

I have a couple of doubts, what happens if the key exists in A but it is not in T.
What happens if the key is in T but not in A.

Try with this macro

Result:
AK key
AL to BC first list

BD is empty
BE Number of records

BF to BU second list



I did a test with 10,000 in the first list and 20,000 in the second list and the time was 4 minutes

Sub Aligning_Rows()
    '
    Dim r1 As Range, r2 As Range, wKey As Range
    Dim k As Long, n As Long
    
    Application.ScreenUpdating = False
    Application.StatusBar = False
    
    Set r1 = Range("A2", Range("A" & Rows.Count).End(xlUp))
    Set r2 = Range("T2", Range("T" & Rows.Count).End(xlUp))
    Range("AK:BU").ClearContents
        
    k = 2
    For Each wKey In r1
        Application.StatusBar = "Reading key : " & wKey.Value
        n = 0
        Set b = r2.Find(wKey.Value, LookAt:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                n = n + 1
                'Cells(b.Row, "S").Value = "Yes"
                Set b = r2.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
            Cells(k, "AK").Value = wKey.Value
            Cells(k, "BE").Value = n
            Range("AL" & k & ":BC" & k).Value = Range("A" & wKey.Row & ":R" & wKey.Row).Value
            Range("BF" & k & ":BU" & k).Value = Range("T" & b.Row & ":AI" & b.Row).Value
        Else
            Cells(k, "AK").Value = wKey.Value
            Range("AL" & k & ":BC" & k).Value = Range("A" & wKey.Row & ":R" & wKey.Row).Value
        End If
        k = k + 1
    Next
    
    Application.ScreenUpdating = True
    Application.StatusBar = False
    
    MsgBox "End"
End Sub

 

[Hu Rocan]

Thanks DanteAmor,
When there is no match, then those records should have a corresponding empty row in the other set. All in all, it basically resumes itself to aligning keys numerically in ascending order. I'll try the macro and see how it fares - will let you know - but thanks again...

 

[DanteAmor]

Test with a sample of data and review the result.

 

[Hu Rocan]

I have. Perhaps it's worth saying that the output should be as follows: line 1 data only exists in columns T to AI, then it only populates columns BF to BU, line 2 data exists in both, so populates columns AL to BD with data from the first list, and columns BF to BU with data from the second list; if a line has data in the first list but not in the second list, it populates columns AL to BD... and so on till the end of the file. This should line up the rows with same keys. If there is duplication in the second list in terms of keys (and there is), return only the first entry but flag that entry with something like a comment in the corresponding cell in column BV if possible so I know that it's a multiple entry...

 

[DanteAmor]

What happened to the macro? Any problem or does not work?
Could you put all possible scenarios between list1 and list2 and their possible solutions in the final list?

You could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[Hu Rocan]

Hi DanteAmor,
Sorry for the late reply, I had some work that needed to get done first. Anyway, I did what you suggested, here's the link to the file: https://app.box.com/s/675n0b6f0hxleddq2h1sqcvkwgz38v9y. This file contains on one side the first list (columns A to R), on the other side the second list (columns T to AH), it's all generic data, except the keys, which are real. The keys in each list are sorted numerically ascending. What I am looking for is a way to align the corresponding rows of data. For example, row 2 in List 1 has a key of 18, which can be found in List 2 on row 3. Row 2 in List 2 has a key of 1. The alignment should then insert a row in List 1 such as to align key 18 in both lists. Where duplicates are found, the duplicate keys in List 2 get a corresponding empty row in List 1.
Hope this explains. And thanks again for your efforts.

 

[DanteAmor]

Try with this. Check the result in AK to BT

Sub Aligning_Rows()
    '
    Dim r1 As Range, r2 As Range, wKey As Range
    Dim k As Long, n As Long, u As Long
    
    Application.ScreenUpdating = False
    Application.StatusBar = False
    
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
    Set r1 = Range("A2", Range("A" & Rows.Count).End(xlUp))
    Set r2 = Range("T2", Range("T" & Rows.Count).End(xlUp))
    
    Range("AK:BU").ClearContents
        
    k = 2
    For Each wKey In r1
        Application.StatusBar = "Reading key : " & wKey.Value
        n = 0
        Set b = r2.Find(wKey.Value, LookAt:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                n = n + 1
                Cells(b.Row, "S").Value = "Yes"
                Set b = r2.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
            Cells(k, "AK").Value = wKey.Value
            Cells(k, "BE").Value = n
            Range("AL" & k & ":BC" & k).Value = Range("A" & wKey.Row & ":R" & wKey.Row).Value
            Range("BF" & k & ":BU" & k).Value = Range("T" & b.Row & ":AI" & b.Row).Value
        Else
            Cells(k, "AK").Value = wKey.Value
            Cells(k, "BF").Value = wKey.Value
            Range("AL" & k & ":BC" & k).Value = Range("A" & wKey.Row & ":R" & wKey.Row).Value
        End If
        k = k + 1
    Next
    '
    'Alinear
    u = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("A1:AH" & u).AutoFilter Field:=Columns("S").Column, Criteria1:="="
    ActiveSheet.Range("T2:AH" & u).Copy
    
    u2 = Range("BF" & Rows.Count).End(xlUp).Row + 1
    ActiveSheet.Range("BF" & u2).PasteSpecial xlValues
    
    ActiveSheet.Range("T2:T" & u).Copy
    u3 = Range("AK" & Rows.Count).End(xlUp).Row + 1
    ActiveSheet.Range("AK" & u3).PasteSpecial xlValues
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
    
    u = Range("AK" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("AK2:BC" & u).Sort key1:=Range("AK2"), order1:=xlAscending, Header:=xlNo
        
    u = Range("BF" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("BE2:BT" & u).Sort key1:=Range("BF2"), order1:=xlAscending, Header:=xlNo
            
    Application.ScreenUpdating = True
    Application.StatusBar = False
    
    MsgBox "End"
End Sub

 

[Hu Rocan]

Quite extraordinary. It seems to be doing exactly what I need. Thank you very much!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.