align duplicates in two columns in Excel

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