compare cells with each other of each row and paste the result

if sheet2 is completely filled with the result then put the remaing result to sheet3 and if sheet3 is also completely filled then paste the rest result to sheet4

Sub CompareCells()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, r As Long, i As Long, ii As Long, j As Long, k As Long
Dim x, y()
Dim symbol As String
Application.ScreenUpdating = False

Set sws = Sheets("Sheet1")
Set dws = Sheets("Sheet2")
dws.Range("A1").CurrentRegion.Clear

lr = sws.Range("A1").CurrentRegion.Rows.Count

For r = 1 To lr
    x = sws.Range("A" & r, sws.Range("A" & r).End(xlToRight)).Value
    ReDim y(1 To 1, 1 To 1)
    For j = 2 To UBound(x, 2) - 1
        For k = j + 1 To UBound(x, 2)
            If x(1, j) > x(1, k) Then
                symbol = ">"
            ElseIf x(1, j) < x(1, k) Then
                symbol = "<"
            Else
                symbol = "="
            End If
            i = i + 1
            ReDim Preserve y(1 To 1, 1 To i)
            y(1, i) = x(1, 1) & symbol & x(1, 1)
        Next k
    Next j
    dws.Range("A" & r).Resize(1, UBound(y, 2)).Value = y
    i = 0
Next r
Application.ScreenUpdating = True
End Sub

Select allOpen in new window