SOLVED

align duplicates in two columns in Excel

Copper Contributor

I have two columns with numbers in each some of the numbers in column 1 exist in column 2 , i want to find the Duplicates and then align them so that the same numbers in each column are in the same row 

10 Replies
best response confirmed by HansVogelaar (MVP)
Solution

@Abdellatif1995 

 

If each column has unique numbers but numbers in one column appear in another column, you may use the following macro to align them. Please click on "Align Duplicates" button on Sheet1 to run the macro. Also, read the instructions in column J to know what to do when the macro is run.

 

To implement this code to your workbook, follow these steps...

1. Open your workbook and press Alt+F11 to open VB Editor.

2. On VB Editor Ribbon, click on Insert and choose Module to insert a New Module.

3. Copy the code given below and paste it into the opened code window of the new module.

4. Save your workbook as Macro-Enabled Workbook.

5. To run the macro in your file, press Alt+F8 to open the Macro window.

6. Choose AlignDuplicates macro from the available macro list and click on Run.

 

Sub AlignDuplicates()
Dim Rng1    As Range
Dim Rng2    As Range
Dim RngOut1 As Range
Dim RngOut2 As Range
Dim dict1   As Object
Dim dict2   As Object
Dim it      As Variant
Dim arr1    As Variant
Dim arr2    As Variant
Dim arrOut1() As Variant
Dim arrOut2() As Variant
Dim i       As Long
Dim ii      As Long
Dim j       As Long

On Error Resume Next
Set Rng1 = Application.InputBox("Select Values in First Column excluding Header!", "Select Range 1!", Type:=8)
On Error GoTo 0

If Rng1 Is Nothing Then
    MsgBox "You didn't select range 1!", vbExclamation
    Exit Sub
ElseIf Rng1.Columns.Count > 1 Then
    MsgBox "You selected a range with more than one column! Select Values in one Column only and then try again...", vbExclamation
    Exit Sub
End If

Set RngOut1 = Rng1.Cells(1)

On Error Resume Next
Set Rng2 = Application.InputBox("Select Values in Second Column excluding Header!", "Select Range 2!", Type:=8)
On Error GoTo 0

If Rng2 Is Nothing Then
    MsgBox "You didn't select range 2!", vbExclamation
    Exit Sub
ElseIf Rng2.Columns.Count > 1 Then
    MsgBox "You selected a range with more than one column! Select Values in one Column only and then try again...", vbExclamation
    Exit Sub
End If

Set RngOut2 = Rng2.Cells(1)

arr1 = Rng1.Value
arr2 = Rng2.Value

Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(arr1, 1)
    dict1.Item(arr1(i, 1)) = ""
Next i

For i = 1 To UBound(arr2, 1)
    dict2.Item(arr2(i, 1)) = ""
Next i

For Each it In dict1.keys
    If dict2.exists(it) Then
        j = j + 1
        ReDim Preserve arrOut1(1 To j)
        ReDim Preserve arrOut2(1 To j)
        arrOut1(j) = it
        arrOut2(j) = it
        dict1.Remove it
        dict2.Remove it
    End If
Next it

For Each it In dict1.keys
    ReDim Preserve arrOut1(1 To UBound(arrOut1, 1) + 1)
    arrOut1(UBound(arrOut1, 1)) = it
Next it

For Each it In dict2.keys
    ReDim Preserve arrOut2(1 To UBound(arrOut2, 1) + 1)
    arrOut2(UBound(arrOut2)) = it
Next it

RngOut1.Resize(UBound(arrOut1)).Value = Application.Transpose(arrOut1)
RngOut2.Resize(UBound(arrOut2)).Value = Application.Transpose(arrOut2)

End Sub

 

This worked like magic , thank you so so much .I'm very grateful to you

You're welcome @Abdellatif1995! Glad it worked as desired.

@Subodh_Tiwari_sktneer thank you for your code, it is excellent. However - is there a way to modify this code to allow for the aligned cells to retain their uniformity across the rows? For example (below), the code aligns columns M and N perfectly, but columns O and P retain their initial value. Is there a way for columns O and P to change as the duplicates are sorted? I have tried manipulating your code to do so, but have not yet found a working solution. 

Dillon_Johnson_0-1706637577107.png


Thank you for your time and consideration,

 

Dillon

 

 

@Abdellatif1995 

Somewhere along the road the rules seem to have changed.  This formula builds a sorted lists of distinct numbers, then looks up each column of data in the combined list and returns the additional data.  By definition, the distinct values would be identical for each column.

= LET(
    distinct, SORT(UNIQUE(TOCOL(numbers, 1))),
    A, XLOOKUP(distinct, columnA, commonText, ""),
    B, XLOOKUP(distinct, columnB, commonText, ""),
    HSTACK(distinct,A,B)
  )

image.png

@Subodh_Tiwari_sktneer I should have been more specific. I just need columns O and P to match column N, post-sort.
Thanks for the reply Peter. I'm not having any luck though. Are you able to paste this function into any cell in the sheet for the output?

@Dillon_Johnson 

The formula can go anywhere and the results will spill down and across.

Be sure to look up the defined names; I never use direct (A1 style) references, only absolute references to named ranges.

@PeterBartholomew1I believe I am referencing the defined names but I'm still coming up shorthanded. Would you be interested in taking a look? Thank you so much!

 

Sort Example 

@Dillon_Johnson 

Sorry, but I clearly misunderstood the nature of your data.  I had assumed that each datetime would be unique within its column, hence my use of XLOOKUP to return the corresponding Tag Index and Value.  It turns out that there are only two datetimes that occur in both the first and second columns, but that there are 107 occurrences within DateAndTime1 and 14 within DateAndTime2.

image.png

 

1 best response

Accepted Solutions
best response confirmed by HansVogelaar (MVP)
Solution

@Abdellatif1995 

 

If each column has unique numbers but numbers in one column appear in another column, you may use the following macro to align them. Please click on "Align Duplicates" button on Sheet1 to run the macro. Also, read the instructions in column J to know what to do when the macro is run.

 

To implement this code to your workbook, follow these steps...

1. Open your workbook and press Alt+F11 to open VB Editor.

2. On VB Editor Ribbon, click on Insert and choose Module to insert a New Module.

3. Copy the code given below and paste it into the opened code window of the new module.

4. Save your workbook as Macro-Enabled Workbook.

5. To run the macro in your file, press Alt+F8 to open the Macro window.

6. Choose AlignDuplicates macro from the available macro list and click on Run.

 

Sub AlignDuplicates()
Dim Rng1    As Range
Dim Rng2    As Range
Dim RngOut1 As Range
Dim RngOut2 As Range
Dim dict1   As Object
Dim dict2   As Object
Dim it      As Variant
Dim arr1    As Variant
Dim arr2    As Variant
Dim arrOut1() As Variant
Dim arrOut2() As Variant
Dim i       As Long
Dim ii      As Long
Dim j       As Long

On Error Resume Next
Set Rng1 = Application.InputBox("Select Values in First Column excluding Header!", "Select Range 1!", Type:=8)
On Error GoTo 0

If Rng1 Is Nothing Then
    MsgBox "You didn't select range 1!", vbExclamation
    Exit Sub
ElseIf Rng1.Columns.Count > 1 Then
    MsgBox "You selected a range with more than one column! Select Values in one Column only and then try again...", vbExclamation
    Exit Sub
End If

Set RngOut1 = Rng1.Cells(1)

On Error Resume Next
Set Rng2 = Application.InputBox("Select Values in Second Column excluding Header!", "Select Range 2!", Type:=8)
On Error GoTo 0

If Rng2 Is Nothing Then
    MsgBox "You didn't select range 2!", vbExclamation
    Exit Sub
ElseIf Rng2.Columns.Count > 1 Then
    MsgBox "You selected a range with more than one column! Select Values in one Column only and then try again...", vbExclamation
    Exit Sub
End If

Set RngOut2 = Rng2.Cells(1)

arr1 = Rng1.Value
arr2 = Rng2.Value

Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(arr1, 1)
    dict1.Item(arr1(i, 1)) = ""
Next i

For i = 1 To UBound(arr2, 1)
    dict2.Item(arr2(i, 1)) = ""
Next i

For Each it In dict1.keys
    If dict2.exists(it) Then
        j = j + 1
        ReDim Preserve arrOut1(1 To j)
        ReDim Preserve arrOut2(1 To j)
        arrOut1(j) = it
        arrOut2(j) = it
        dict1.Remove it
        dict2.Remove it
    End If
Next it

For Each it In dict1.keys
    ReDim Preserve arrOut1(1 To UBound(arrOut1, 1) + 1)
    arrOut1(UBound(arrOut1, 1)) = it
Next it

For Each it In dict2.keys
    ReDim Preserve arrOut2(1 To UBound(arrOut2, 1) + 1)
    arrOut2(UBound(arrOut2)) = it
Next it

RngOut1.Resize(UBound(arrOut1)).Value = Application.Transpose(arrOut1)
RngOut2.Resize(UBound(arrOut2)).Value = Application.Transpose(arrOut2)

End Sub

 

View solution in original post