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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
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
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.