VBA Code to make two columns with dates the same

Hi there,

I attach the file I'm working with. It contains two columns with dates and I want to make them containing exactly the same values. For example, A22 = 01/02/2005 while there is no such date in column B. Hence, I want to delete this so 02/02/2005 comes up and it is equal to cell B22. Then it continues and we have a cell in column A with the date 14/03/2005 but it corresponds with 11/03/2005 on the same row in column B, therefore the cell in column B must be deleted until the two get equal and so on. I wrote the following code:

Sub Whatever()
    For i = 1 To 2246
        If Worksheets("Dates").Cells(1 + i, 1) < Worksheets("Dates").Cells(1 + i, 2) Then
                Worksheets("Dates").Cells(1 + i, 1).Delete Shift:=xlUp
                
                Do Until Worksheets("Dates").Cells(1 + i, 1) >= Worksheets("Dates").Cells(1 + i, 2)
                Loop
                
        ElseIf Worksheets("Dates").Cells(1 + i, 1) > Worksheets("Dates").Cells(1 + i, 2) Then
        
            Do Until Worksheets("Dates").Cells(1 + i, 1) = Worksheets("Dates").Cells(1 + i, 2)
                Worksheets("Dates").Cells(1 + i, 2).Delete Shift:=xlUp
            Loop
        End If
    Next i
        
End Sub

and it runs through the observations up to the beginning of 2006 when it can't go any further. I would greatly appreciate any suggestions on your side. Thank you! Dates.xlsx

Probably not the most efficient but i am sleepy and it is what comes to the top of my mind:

Sub RunMe()
Dim ws As Worksheet:    Set ws = Sheets("Dates")
Dim iRow As Long, lastrow As Long

Application.ScreenUpdating = False

iRow = 2
lastrow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row

Do
    If ws.Range("A" & iRow).Value < ws.Range("B" & iRow).Value Then
        ws.Range("A" & iRow).Delete Shift:=xlUp
    ElseIf ws.Range("A" & iRow).Value > ws.Range("B" & iRow).Value Then
        ws.Range("B" & iRow).Delete Shift:=xlUp
    Else
        iRow = iRow + 1
    End If
Loop Until iRow >= lastrow Or ws.Range("A" & iRow).Value = ""

Application.ScreenUpdating = True

End Sub

Hi n_ant,
try it

Sub ertert()
Dim x, y(), i&, j&
With Range("A1").CurrentRegion
    x = .Value
    ReDim y(1 To UBound(x), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        '            .CompareMode = 1
        For i = 2 To UBound(x)
            .Item(x(i, 1)) = 1
        Next i
        For i = 2 To UBound(x)
            If .Exists(x(i, 2)) Then
                j = j + 1
                y(j, 1) = x(i, 2)
                y(j, 2) = x(i, 2)
            End If
        Next i
    End With
    .Offset(1).ClearContents
    .Offset(1).Resize(j, 2).Value = y()
End With
End Sub

Thank you all for your suggestions! That's awesome. Words can't express my gratitude