special sort option

[Owens2125]

I have a workbook containing several scores for different teams. How can I
sort the total scores for each team by highest to lowest while still keeping
all the other team info with it?

Ex.
Team 1 Day 1 Day 2 Total
Bluejays 46 44 90

Team 2 Day 1 Day 2 Total
Cardinals 43 49 92

 

[Gary Keramidas]

send me your email address and i'll send you something to try.

 

[Gary Keramidas]

i'll try and post this and hope it doesn't wrap.
i assumed the data started in A1 on sheet1 and use sheet3 to do a sort. if this
is not the case or you don't have a sheet3, then it will have to be modified.

Option Explicit
Sub Macro1()
Dim ws As Worksheet
Dim lastcol As Long
Dim lastrow As Long
Dim x As Long, z As Long, w As Long, y As Long
Dim i As Long, n As Long, k As Long

Dim arr() As Variant
Dim arr2() As Variant
Dim arr3() As Variant
Dim cell As Range
Dim lastrow3 As Long
Dim ws3 As Worksheet
Set ws = Worksheets("Sheet1")
Set ws3 = Worksheets("Sheet3")
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
lastcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For x = 2 To lastrow Step 3
ReDim Preserve arr(0 To z)
arr(z) = ws.Range("A" & x - 1 & ":" & Cells(x, lastcol).Address)
z = z + 1
Next
z = 0

For i = LBound(arr) To UBound(arr)
ReDim Preserve arr2(0 To z)
ReDim Preserve arr3(0 To z)
arr2(z) = arr(i)(2, lastcol)
arr3(z) = arr(i)(1, 1)
z = z + 1
Next i
y = 1
For w = LBound(arr) To UBound(arr)
ws3.Range("A" & w + 1).Value = arr(w)(1, 1)
ws3.Range("B" & w + 1).Value = Application.Max(arr(w))
Next
With ws3.Columns("A:B")
.Sort Key1:=.Range("B1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With

lastrow3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In ws3.Range("A1:A" & lastrow3)
Do While cell.Value <> arr(n)(1, 1)
n = n + 1
Loop
ws.Range("A1:" & Cells(2, lastcol).Address).Offset(k) = arr(n)
ws.Cells(2, lastcol).Offset(k).Formula = "=sum(" & _
ws.Range("B2").Offset(k).Address & ":" & ws.Cells(2, lastcol - _
1).Offset(k).Address & ")"
k = k + 3
n = 0
Next
ws3.Cells.Clear
End Sub

 

[Gary Keramidas]

it was late so i took the easy way to sort the data. this one doesn't need a
sheet to do the sorting, so as long as your data starts is a1, it should work.

Option Explicit
Sub Macro2()
Dim ws As Worksheet
Dim lastcol As Long
Dim lastrow As Long
Dim x As Long, z As Long, w As Long, y As Long
Dim i As Long, n As Long, k As Long, j As Long
Dim temp0 As String, temp1 As Long
Dim arr() As Variant
Dim arr2() As Variant
Dim arr3() As Variant
Set ws = Worksheets("Sheet1")
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
lastcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For x = 2 To lastrow Step 3
ReDim Preserve arr(0 To z)
arr(z) = ws.Range("A" & x - 1 & ":" & Cells(x, lastcol).Address)
z = z + 1
Next
z = 0

For i = LBound(arr) To UBound(arr)
ReDim Preserve arr2(0 To z)
ReDim Preserve arr3(0 To z)
arr2(z) = arr(i)(2, lastcol)
arr3(z) = arr(i)(1, 1)
z = z + 1
Next i
y = 1

'sort the array
For i = LBound(arr2) To UBound(arr2) - 1
For j = i + 1 To UBound(arr)
If arr2(i) < arr2(j) Then
temp0 = arr3(j)
temp1 = arr2(j)

arr3(j) = arr3(i)
arr2(j) = arr2(i)

arr3(i) = temp0
arr2(i) = temp1
End If
Next j
Next i

For w = LBound(arr3) To UBound(arr3)
Do While arr3(w) <> arr(n)(1, 1)
n = n + 1
Loop
ws.Range("A1:" & Cells(2, lastcol).Address).Offset(k) = arr(n)
ws.Cells(2, lastcol).Offset(k).Formula = "=sum(" & _
ws.Range("B2").Offset(k).Address(0, 0) & ":" & ws.Cells(2, lastcol _
- 1).Offset(k).Address(0, 0) & ")"
k = k + 3
n = 0
Next
End Sub