Sort rows by equation

Hello to all,
I would like to set macro which will be called using button. What macro actually has to do is to sort all rows by this order:
1. To recognize which of the rows in the table has the Center-X.Value=1 and Center-Y.Value=0 and to move entire row in the nested position below first row (header titles)
2. To sort all other rows by equation: StartPoint-X(i).Value=EndPoint-X(i-1)
Note: "StartPoint-X" & "EndPoint-X" are just names in header row

I have created some code in the attached workbook but I have to modify it.
Also, there are two images which show table before and after sorting. This is done manually just to show what I would like to do.
I would appreciate if someone could help me.
This is unsorted table.
unsorted.PNG
This is sorted table.
sorted.PNG

Code:

Sub Button1_Click()

'Insert first empty row at A2 cause A1 is reserved for header line
Rows(2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Dim X1, Y1, X2, Y2, XC, YC As Double

Dim i As Integer
For i = 2 To 100
    X1 = Sheets("Sheet2").Range("A" & i).Value
    Y1 = Sheets("Sheet2").Range("B" & i).Value
    X2 = Sheets("Sheet2").Range("C" & i).Value
    Y2 = Sheets("Sheet2").Range("D" & i).Value
    XC = Sheets("Sheet2").Range("E" & i).Value
    YC = Sheets("Sheet2").Range("F" & i).Value
    
    If YC = 0 And XC <> 0 Then
    'Cut the row where is YC = 0 And XC <> 0
        Sheets("Sheet2").Range("A" & i).EntireRow.Cut Destination:=Sheets("Sheet2").Range("A" & 2)
    End If

    Dim SearchRange As Range
    Set SearchRange = Sheets("Sheet2").Columns("A").Find(what:=X2, LookIn:=xlValues, lookat:=xlWhole)
    If SearchRange Is Nothing Then
    MsgBox ("There is no row 'i' where in column A the value X(i) has value of X2")
    Else
    
    Dim m As Long, r As Range
    For m = 1 To Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
        Set r = Sheets("Sheet2").Range("A" & m)
        If Len(r.Value) = 0 Then
            MsgBox "No Value, in " & r.Address
            Sheets("Sheet2").Range("A" & SearchRange.Row).EntireRow.Cut Destination:=Sheets("Sheet2").Range("A" & m)
        End If
    Next
       
    End If
Next

End Sub

Thank you! It works perfect! Very appreciate your help!

I missed something . The values that I am trying to arrange are coordinates of some sketch items from AutoCAD. Sometimes, during a export from the AutoCAD, coordinates of StartPoint and EndPoint of the lines (Lines can be recognized by CenterPoint -X=0 and CenterPoint-Y=0) are switched so I have to do it manually as on the video. It would be the best if macro recognize is there a comparing value in the column A, if there is not, then search in the column C and when you found it then switch cells, StartPoint coordinates go on the places of the EndPoint and opposite (EndPoint coordinates go on the places of the StartPoint).

I had a problem to update the video. Sorry.
https://youtu.be/kh-R4pSThvo

Originally Posted by karedog

I will assume that first starting point is the row which both Center-X and Center-Y is 0 (not 1 and 0 like in your first attached file).
In the example attached, I switched some StartPoint and EndPoint nodes to mimic your request.

Private Function isCollExists(coll As Collection, ByVal strKey As String) As Boolean
  On Error Resume Next
  With coll(strKey)
    If Err.Number = 0 Then isCollExists = True Else isCollExists = False
  End With
End Function
Sub Test()
  Dim arr(), c As New Collection, rng As Range, i As Long, j As Long, k As Long, p As Long, v
  With Sheets("Sheet2")
    Set rng = .Range("A1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row)
  End With
  With rng
    arr = .Value
    For i = 2 To UBound(arr, 1)
        If Len(arr(i, 1)) Then
           If arr(i, 5) = 0 And arr(i, 6) = 0 Then
              j = i
              arr(i, 7) = 1
           Else
              If isCollExists(c, arr(i, 1) & "|" & arr(i, 2)) Then
                 c.Add key:=arr(i, 3) & "|" & arr(i, 4), Item:=i
              Else
                 c.Add key:=arr(i, 1) & "|" & arr(i, 2), Item:=i
              End If
           End If
        End If
    Next i
    If j = 0 Then Exit Sub
    p = 1
    Do
       If isCollExists(c, arr(j, 3) & "|" & arr(j, 4)) Then
          k = c(arr(j, 3) & "|" & arr(j, 4))
          c.Remove arr(j, 3) & "|" & arr(j, 4)
          p = p + 1
          arr(k, 7) = p
          j = k
       ElseIf isCollExists(c, arr(j, 1) & "|" & arr(j, 2)) Then
          k = c(arr(j, 1) & "|" & arr(j, 2))
          c.Remove arr(j, 1) & "|" & arr(j, 2)
          v = arr(j, 1): arr(j, 1) = arr(j, 3): arr(j, 3) = v
          v = arr(j, 2): arr(j, 2) = arr(j, 4): arr(j, 4) = v
          p = p + 1
          arr(k, 7) = p
          j = k
       Else
          Exit Do
       End If
    Loop
   .Value = arr
    .Sort key1:=.Columns(7), order1:=xlAscending, header:=xlYes
    .Columns(7).ClearContents
  End With
End Sub

Hello karedog,
The previous code that you wrote works PERFECT, with one simple modification that I am trying to do. Problem happens when program can't find the same value in the column A.
Actually the value is in the column C and cells must change places. A(i)goes to C(i) and C(i) goes to A(i). The same is for other two cells B(i) and D(i).
So if program during a loop can't find a value in the column A, then search in the column C and when program found the value in the column C then send C.value & D.value on the place of A.value and B.value, and opposite.
https://youtu.be/D-u3huNmCHo

Originally Posted by karedog

I will assume that first starting point is the row which both Center-X and Center-Y is 0 (not 1 and 0 like in your first attached file).
In the example attached, I switched some StartPoint and EndPoint nodes to mimic your request.

The first starting point is row with Center-X<>0 and Center-Y=0.
When I started the topic, I have set to be Center-X=1 and Center-Y=0 to simplify the problem and I have used integer numbers for easy comparison between two cells.

I have changed just this row in your first code and it works fine.

If arr(i, 5) = 1 And arr(i, 6) = 0 Then

is changed to:

If arr(i, 5) <>0 And arr(i, 6) = 0 Then

Originally Posted by karedog

This information is never mentioned before, so is the "non continous" range.

However, you can spot where the line to fix this.

So, if that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

Capture2.PNG

I don't worry about the starting row. Program recognize the starting row exactly as I wanted.

Originally Posted by karedog

You must unmerge G8:M8 first, then run this sub :

Private Function isCollExists(coll As Collection, ByVal strKey As String) As Boolean
  On Error Resume Next
  With coll(strKey)
    If Err.Number = 0 Then isCollExists = True Else isCollExists = False
  End With
End Function
Sub Test()
  Dim arr(), c As New Collection, rng As Range, i As Long, p As Long, s As String, s1 As String, s2 As String, v
  With Sheets("Sheet1")
    Set rng = .Range("A1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row)
  End With
  With rng
    arr = .Value
    For i = 2 To UBound(arr, 1)
        If Len(arr(i, 1)) Then
           If arr(i, 5) <> 0 And arr(i, 6) = 0 Then
              p = i
              arr(i, 7) = 1
           Else
              s1 = arr(i, 1) & "|" & arr(i, 2)
              s2 = arr(i, 3) & "|" & arr(i, 4)
              On Error Resume Next
                 c.Add key:=s1, Item:=New Collection
                 c.Add key:=s2, Item:=New Collection
              On Error GoTo 0
              c(s1).Add key:=CStr(i), Item:=i
              c(s2).Add key:=CStr(i), Item:=i
           End If
        End If
    Next i
    i = p: p = 1: If i = 0 Then Exit Sub
    Do
       s1 = arr(i, 1) & "|" & arr(i, 2)
       s2 = arr(i, 3) & "|" & arr(i, 4)
       If isCollExists(c, s2) Then
          s = s2
       ElseIf isCollExists(c, s1) Then
          v = arr(i, 1): arr(i, 1) = arr(i, 3): arr(i, 3) = v
          v = arr(i, 2): arr(i, 2) = arr(i, 4): arr(i, 4) = v
          s = s1
       Else
          Exit Do
       End If
       On Error Resume Next
          c(s).Remove CStr(i)
          i = 0
          i = c(s)(1)
          c.Remove s
       On Error GoTo 0
       If i > 0 Then
          p = p + 1
          arr(i, 7) = p
       Else
          Exit Do
       End If
    Loop
    .Value = arr
    .Sort key1:=.Columns(7), order1:=xlAscending, Header:=xlYes
    .Columns(7).ClearContents
  End With
End Sub

Hi @karedog
That's what I was trying to do. Thank you very much.
SOLVED!

Originally Posted by karedog

You are welcome, glad I can help.

Regards

Hello karedog,
I would like to say thank you again cause code bellow that you wrote works perfect.

'Option Explicit

Private Function isCollExists(coll As Collection, ByVal strKey As String) As Boolean
  On Error Resume Next
  With coll(strKey)
    If Err.Number = 0 Then isCollExists = True Else isCollExists = False
  End With
End Function

Sub Button1_Click()
Dim arr(), c As New Collection, rng As Range, i As Long, p As Long, s As String, s1 As String, s2 As String, v
  With Sheets("Sheet1")
    Set rng = .Range("A1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row)
  End With
  With rng
    arr = .Value
    For i = 2 To UBound(arr, 1)
        If Len(arr(i, 1)) Then
           If arr(i, 5) <> 0 And arr(i, 6) = 0 Then
              p = i
              arr(i, 7) = 1
           Else
              s1 = arr(i, 1) & "|" & arr(i, 2)
              s2 = arr(i, 3) & "|" & arr(i, 4)
              On Error Resume Next
                 c.Add Key:=s1, Item:=New Collection
                 c.Add Key:=s2, Item:=New Collection
              On Error GoTo 0
              c(s1).Add Key:=CStr(i), Item:=i
              c(s2).Add Key:=CStr(i), Item:=i
           End If
        End If
    Next i
    i = p: p = 1: If i = 0 Then Exit Sub
    Do
       s1 = arr(i, 1) & "|" & arr(i, 2)
       s2 = arr(i, 3) & "|" & arr(i, 4)
       If isCollExists(c, s2) Then
          s = s2
       ElseIf isCollExists(c, s1) Then
          v = arr(i, 1): arr(i, 1) = arr(i, 3): arr(i, 3) = v
          v = arr(i, 2): arr(i, 2) = arr(i, 4): arr(i, 4) = v
          s = s1
       Else
          Exit Do
       End If
       On Error Resume Next
          c(s).Remove CStr(i)
          i = 0
          i = c(s)(1)
          c.Remove s
       On Error GoTo 0
       If i > 0 Then
          p = p + 1
          arr(i, 7) = p
       Else
          Exit Do
       End If
    Loop
    .Value = arr
    .Sort key1:=.Columns(7), order1:=xlAscending, Header:=xlYes
    .Columns(7).ClearContents
  End With
End Sub

I would like just to know, is it possible to catch the moment where in the row, StartPoint and EndPoint are switched positions?
In other words, to add new string value in the column "G" and row (i).

Worksheets(1).Range("G" & i).Value= "YES"

If StartPoint and EndPoint are switched positions
or

Worksheets(1).Range("G" & i).Value= "NO"

if StarPoint and EndPoint are not switched positions.

It is very important to catch the switch change for my CAD application.
img16.PNG

Originally Posted by karedog

Should be :

Private Function isCollExists(coll As Collection, ByVal strKey As String) As Boolean
  On Error Resume Next
  With coll(strKey)
    If Err.Number = 0 Then isCollExists = True Else isCollExists = False
  End With
End Function
Sub Test()
  Dim arr(), c As New Collection, rng As Range, i As Long, p As Long, s As String, s1 As String, s2 As String, v
  With Sheets("Sheet1")
    Set rng = .Range("A1:H" & .Cells(.Rows.Count, "A").End(xlUp).Row)
  End With
  With rng
    arr = .Value
    For i = 2 To UBound(arr, 1)
        If Len(arr(i, 1)) Then
           If arr(i, 5) <> 0 And arr(i, 6) = 0 Then
              p = i
              arr(i, 7) = 1
           Else
              s1 = arr(i, 1) & "|" & arr(i, 2)
              s2 = arr(i, 3) & "|" & arr(i, 4)
              On Error Resume Next
                 c.Add key:=s1, Item:=New Collection
                 c.Add key:=s2, Item:=New Collection
              On Error GoTo 0
              c(s1).Add key:=CStr(i), Item:=i
              c(s2).Add key:=CStr(i), Item:=i
           End If
        End If
    Next i
    i = p: p = 1: If i = 0 Then Exit Sub
    Do
       s1 = arr(i, 1) & "|" & arr(i, 2)
       s2 = arr(i, 3) & "|" & arr(i, 4)
       If isCollExists(c, s2) Then
          s = s2
          arr(i, 8) = "No"
       ElseIf isCollExists(c, s1) Then
          v = arr(i, 1): arr(i, 1) = arr(i, 3): arr(i, 3) = v
          v = arr(i, 2): arr(i, 2) = arr(i, 4): arr(i, 4) = v
          s = s1
          arr(i, 8) = "Yes"
       Else
          Exit Do
       End If
       On Error Resume Next
          c(s).Remove CStr(i)
          i = 0
          i = c(s)(1)
          c.Remove s
       On Error GoTo 0
       If i > 0 Then
          p = p + 1
          arr(i, 7) = p
       Else
          Exit Do
       End If
    Loop
    arr(1, 8) = "Inverse direction"
    .Value = arr
    .Sort key1:=.Columns(7), order1:=xlAscending, Header:=xlYes
    .Columns(7).Delete xlShiftToLeft
  End With
End Sub

Perfect!
Thank you!