Aligning whole rows with the same data

[mrtim2232]

Morning all, I have taken the following macro and have tried to make it work for my spreadsheet whilst it doesn't cause an error it does however delete some of the data and I can't understand why as there doesn't appear to be a pattern to the data it clears. Any help on this would be appreciated.

Sub alignment()Dim rg1 As Range, rg2 As Range, firstMatch As Boolean
Dim i As Long, j As Long, foundRow As Long


Application.ScreenUpdating = False


If Selection.Areas.Count <> 2 Then
MsgBox "Select two areas"
Exit Sub
End If


Set rg1 = Selection.Areas(1)
Set rg2 = Selection.Areas(2)


'gets the number of unique values in the first rows of range 1 and 2, to be able to run the loop all the way
Dim cUnique As New Collection


On Error Resume Next


With rg1
For i = 1 To .Columns(1).Cells.Count
cUnique.Add .Cells(i, 1), CStr(.Cells(i, 1))
Next
End With


With rg2
For i = 1 To .Columns(1).Cells.Count
cUnique.Add .Cells(i, 1), CStr(.Cells(i, 1))
Next
End With


On Error GoTo 0


'boolean needed to be able to resize range 2 if required
firstMatch = True


For i = 1 To cUnique.Count
If WorksheetFunction.CountA(rg1.Rows(i)) = 0 _
Or WorksheetFunction.CountA(rg2.Rows(i)) = 0 _
Or rg1.Cells(i, 1).Offset(0, rg2.Column - rg1.Column) = rg1.Cells(i, 1) Then
firstMatch = False
GoTo nxt_i:
End If


On Error Resume Next
foundRow = rg2.Columns(1).Find(What:=rg1.Cells(i, 1), LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Row


If Err <> 0 Then
Err.Clear
rg1.Cells(i, 1).Offset(0, rg2.Column - rg1.Column).Resize(, rg2.Columns.Count).Insert Shift:=xlDown
If firstMatch Then Set rg2 = rg2.Offset(-1).Resize(rg2.Rows.Count + 1)
Else
If i < foundRow Then
rg1.Offset(i - 1).Cut Cells(foundRow, rg1.Column)
Else
rg2.Rows(foundRow - rg2.Row + 1).Cut
rg2.Rows(i).Insert Shift:=xlDown
End If


firstMatch = False
End If


nxt_i:


Next


Application.ScreenUpdating = True
End Sub