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

we have to compare all cells of each row with each other
we don’t have to compare 1st row with 2nd row or 3rd row ,we have to compare 1st row all cells with each other
and paste the result to sheet2 and 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(this is just a sample file so there are less data in this file in actual file i have lots of data and big rows of data)
this highlighted colour is only for understanding purpose
Book15.xlsm
Who is Participating?

Excel & VBA ExpertCommented:
Okay, please give this a try and see if that produces the desired output.

``````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 cnt As Long, m As Long, n As Long, o As Long
Dim x, y(), Arr()
Dim symbol As String
Application.ScreenUpdating = False

Set sws = Sheets("Sheet1")
Set dws = Sheets("Sheet2")

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
cnt = 1
For m = 1 To UBound(y, 2) Step 16384
cnt = cnt + 1
ReDim Arr(1 To 1, 1 To m + 16384 - 1)
For n = m To m + 16384 - 1
o = o + 1
If n > UBound(y, 2) Then Exit For
Arr(1, o) = y(1, n)
Next n
On Error Resume Next
Set dws = Sheets("Sheet" & cnt)
dws.Rows(r).Clear
On Error GoTo 0
If dws Is Nothing Then
dws.Name = "Sheet" & cnt
End If
dws.Range("A" & r).Resize(1, 16384).Value = Arr
Set dws = Nothing
o = 0
Next m
i = 0
o = 0
Next r
sws.Activate
Application.ScreenUpdating = True
End Sub
``````
0

Excel & VBA ExpertCommented:
I don't think I quite understood your requirement specially when you say something like below...
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

BTW, please give this a try which will populate the Sheet2 as you showed in your sample file.

``````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
``````
0

Author Commented:
this code is 101% perfect
But neeraj sir kindly see this sample file we have to do same thing in this sample file also but we cant do that bcoz there are big rows of data and the result is also big it will not be fitted only  in sheet2 thats y i said 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
so plz look this sample file and modify the code
Book15--2-.xlsm
0

Author Commented:
Thnx Neeraj sir for ur great support  and thnx once again for giving ur precious time to this post
0

Excel & VBA ExpertCommented:
You're welcome Avinash!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.