Option Explicit
Public Sub CompareBottomToTop()
' with this line code will work faster
Application.ScreenUpdating = False
' two ranges with data
' Left one contains source data
' Right one receives missed records
Dim LeftRange As Range
Dim RightRange As Range
' get the left range
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Set LeftRange = Range(Selection, Selection.End(xlDown))
' get the right range
Range("A1").Select
' skip left range
Selection.End(xlToRight).Select
' one step to select leftmost cell in the right range
Selection.End(xlToRight).Select
' get the range
Range(Selection, Selection.End(xlToRight)).Select
Set RightRange = Range(Selection, Selection.End(xlDown))
' rows to navigate through left and right ranges
Dim LeftRow As Long
Dim RightRow As Long
' we start from the last row
LeftRow = LeftRange.Rows.Count
RightRow = RightRange.Rows.Count
' cell to be copied
Dim Cell As Range
' main loop
While LeftRow > 0 And RightRow > 0
' if left cell is less than right one - right row is not present on the left side
If LeftRange.Cells(LeftRow, 1) < RightRange.Cells(RightRow, 1) Then
' highlight it and skip
RightRange.Rows(RightRow).Interior.Color = vbGreen
RightRow = RightRow - 1
ElseIf LeftRange.Cells(LeftRow, 1) = RightRange.Cells(RightRow, 1) Then
' both rows have same key - skip
LeftRow = LeftRow - 1
RightRow = RightRow - 1
Else
' left row is not present on the right side
With RightRange
' insert empty space
.Rows(RightRow + 1).Insert Shift:=xlDown
' go through every cell in the left row and copy it to the right
For Each Cell In LeftRange.Rows(LeftRow).Cells
.Cells(RightRow + 1, Cell.Column - LeftRange.Column + 1) = Cell
Next
' highlight with color
.Rows(RightRow + 1).Interior.Color = vbYellow
End With
' skip row that we've copied
LeftRow = LeftRow - 1
End If
Wend
Application.ScreenUpdating = True
End Sub
Public Sub CompareTopToBottom()
Application.ScreenUpdating = False
Dim LeftRange As Range
Dim RightRange As Range
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Set LeftRange = Range(Selection, Selection.End(xlDown))
Range("A1").Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlToRight)).Select
Set RightRange = Range(Selection, Selection.End(xlDown))
Dim LeftRow As Long
Dim RightRow As Long
LeftRow = 1
RightRow = 1
Dim Cell As Range
While LeftRow <= LeftRange.Rows.Count And RightRow <= RightRange.Rows.Count
If LeftRange.Cells(LeftRow, 1) > RightRange.Cells(RightRow, 1) Then
RightRange.Rows(RightRow).Interior.Color = vbGreen
RightRow = RightRow + 1
ElseIf LeftRange.Cells(LeftRow, 1) = RightRange.Cells(RightRow, 1) Then
LeftRow = LeftRow + 1
RightRow = RightRow + 1
Else
With RightRange
.Rows(RightRow).Insert Shift:=xlDown
For Each Cell In LeftRange.Rows(LeftRow).Cells
.Cells(RightRow, Cell.Column - LeftRange.Column + 1) = Cell
Next
.Rows(RightRow).Interior.Color = vbYellow
End With
LeftRow = LeftRow + 1
RightRow = RightRow + 1
End If
Wend
' this this case we need to copy rows, that may left in the left range
While LeftRow <= LeftRange.Rows.Count
With RightRange
.Rows(RightRow).Insert Shift:=xlDown
For Each Cell In LeftRange.Rows(LeftRow).Cells
.Cells(RightRow, Cell.Column - LeftRange.Column + 1) = Cell
Next
.Rows(RightRow).Interior.Color = vbYellow
End With
LeftRow = LeftRow + 1
RightRow = RightRow + 1
Wend
Application.ScreenUpdating = True
End Sub
