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
Avinash SinghAsked:
Who is Participating?
 
Subodh Tiwari (Neeraj)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
            Set dws = Sheets.Add(after:=Sheets(Sheets.Count))
            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

Open in new window

0
 
Subodh Tiwari (Neeraj)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

Open in new window

0
 
Avinash SinghAuthor 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
 
Avinash SinghAuthor Commented:
Thnx Neeraj sir for ur great support  and thnx once again for giving ur precious time to this post
0
 
Subodh Tiwari (Neeraj)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.

All Courses

From novice to tech pro — start learning today.