Sort largest number in middle, expanding to smaller numbers outward both up and down

[Gadman]

I have a list of numbers, the list size could be varying in size from 1 to 60. Here is an example:

1
2
3
4
5
6
7

I need to sort it to where the LARGEST number is in the middle and it gradually gets smaller going outwards, think of balancing a weight in the center of a pivot point. For example:

1
3
5
7
6
4
2

Note the list of numbers could be up to 60 entries.

I'm stumped

 

[offthelip]

try this I have assumed the numbers are in column A and I have pasted the results in column B for testing, easily changed

Sub midsort()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    
    With ActiveSheet.Sort
        
        .SortFields.Add Key:=Range(Cells(1, 1), Cells(lastrow, 1)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(Cells(1, 1), Cells(lastrow, 1))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    inarr = Range(Cells(1, 1), Cells(lastrow, 1)) ' load al data into a variant array
    ReDim outarr(1 To UBound(inarr), 1 To 1)
 ' determine if even or odd number of numbers
   If lastrow Mod 2 = 0 Then
    startdn = lastrow / 2
    startup = startdn + 1
   Else
    startrow = (lastrow + 1) / 2
    outarr(startrow, 1) = inarr(lastrow, 1)
    startdn = startrow - 1
    startup = startrow + 1
    lastrow = lastrow - 1
   End If
   
   For i = lastrow To 1 Step -2
    outarr(startup, 1) = inarr(i, 1)
    outarr(startdn, 1) = inarr(i - 1, 1)
    startup = startup + 1
    startdn = startdn - 1
   Next i
Range(Cells(1, 2), Cells(lastrow, 2)) = outarr

End Sub

 

[Fluff]

What version of Excel are you using?

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[Gadman]

What version of Excel are you using?

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Microsoft® Excel® for Microsoft 365 MSO (Version 2302 Build 16.0.16130.20186) 64-bit

 

[Gadman]

try this I have assumed the numbers are in column A and I have pasted the results in column B for testing, easily changed

Sub midsort()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
   
    With ActiveSheet.Sort
       
        .SortFields.Add Key:=Range(Cells(1, 1), Cells(lastrow, 1)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(Cells(1, 1), Cells(lastrow, 1))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    inarr = Range(Cells(1, 1), Cells(lastrow, 1)) ' load al data into a variant array
    ReDim outarr(1 To UBound(inarr), 1 To 1)
 ' determine if even or odd number of numbers
   If lastrow Mod 2 = 0 Then
    startdn = lastrow / 2
    startup = startdn + 1
   Else
    startrow = (lastrow + 1) / 2
    outarr(startrow, 1) = inarr(lastrow, 1)
    startdn = startrow - 1
    startup = startrow + 1
    lastrow = lastrow - 1
   End If
  
   For i = lastrow To 1 Step -2
    outarr(startup, 1) = inarr(i, 1)
    outarr(startdn, 1) = inarr(i - 1, 1)
    startup = startup + 1
    startdn = startdn - 1
   Next i
Range(Cells(1, 2), Cells(lastrow, 2)) = outarr

End Sub

Running this script with the numbers 1-35 displays this:

Half way there, I need it to go downwards from this point with the remaining numbers!

 

[offthelip]

I think you must have made some error in copying the code because it works fine for me, although I did spot an error on the "odd" case where it wasn't writing the very last value to the workhseet so I have changed one line of code:
try this:

Sub midsort()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
   
    With ActiveSheet.Sort
       
        .SortFields.Add Key:=Range(Cells(1, 1), Cells(lastrow, 1)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(Cells(1, 1), Cells(lastrow, 1))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    inarr = Range(Cells(1, 1), Cells(lastrow, 1)) ' load al data into a variant array
    ReDim outarr(1 To UBound(inarr), 1 To 1)
 ' determine if even or odd number of numbers
   If lastrow Mod 2 = 0 Then
    startdn = lastrow / 2
    startup = startdn + 1
   Else
    startrow = (lastrow + 1) / 2
    outarr(startrow, 1) = inarr(lastrow, 1)
    outarr(lastrow, 1) = inarr(2, 1)
    startdn = startrow - 1
    startup = startrow + 1
    lastrow = lastrow - 1
   End If
  
   For i = lastrow To 1 Step -2
    outarr(startup, 1) = inarr(i, 1)
    outarr(startdn, 1) = inarr(i - 1, 1)
    startup = startup + 1
    startdn = startdn - 1
   Next i
Range(Cells(1, 2), Cells(UBound(outarr, 1), 2)) = outarr  ' change this line of code

End Sub

 

[Gadman]

I think you must have made some error in copying the code because it works fine for me, although I did spot an error on the "odd" case where it wasn't writing the very last value to the workhseet so I have changed one line of code:
try this:

Sub midsort()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
  
    With ActiveSheet.Sort
      
        .SortFields.Add Key:=Range(Cells(1, 1), Cells(lastrow, 1)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(Cells(1, 1), Cells(lastrow, 1))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    inarr = Range(Cells(1, 1), Cells(lastrow, 1)) ' load al data into a variant array
    ReDim outarr(1 To UBound(inarr), 1 To 1)
 ' determine if even or odd number of numbers
   If lastrow Mod 2 = 0 Then
    startdn = lastrow / 2
    startup = startdn + 1
   Else
    startrow = (lastrow + 1) / 2
    outarr(startrow, 1) = inarr(lastrow, 1)
    outarr(lastrow, 1) = inarr(2, 1)
    startdn = startrow - 1
    startup = startrow + 1
    lastrow = lastrow - 1
   End If
 
   For i = lastrow To 1 Step -2
    outarr(startup, 1) = inarr(i, 1)
    outarr(startdn, 1) = inarr(i - 1, 1)
    startup = startup + 1
    startdn = startdn - 1
   Next i
Range(Cells(1, 2), Cells(UBound(outarr, 1), 2)) = outarr  ' change this line of code

End Sub

This worked perfectly:

Thanks.