Dim objArrLst As Object
Dim IntColor As Double
Sub GroupSortRake()
Dim NextCol As Long
InteriorSort
NextCol = ActiveSheet.UsedRange.Columns.Count - 1
DoCopy NextCol, True
End Sub
Private Sub DoCopy(myOffset As Long, DelIt As Boolean)
Dim x As Long
Dim sRng As String
Dim c As Range
For Each c In ActiveSheet.UsedRange
If c.Interior.Color <> IntColor Then
sRng = Mid(objArrLst(x), InStr(objArrLst(x), "$"))
Range(sRng).Copy Destination:=c.Offset(0, myOffset)
x = x + 1
End If
Next c
If DelIt Then _
Range(Columns(ActiveSheet.UsedRange.Columns(1).Column), Columns(myOffset + 1)).Delete
End Sub
Private Sub InteriorSort()
Dim fLen As Long
Dim c As Range
For Each c In ActiveSheet.UsedRange
If Len(c.Formula) > fLen Then fLen = Len(c.Formula)
Next c
IntColor = Cells(Rows.Count, Columns.Count).Interior.Color
Set objArrLst = CreateObject("System.collections.arraylist")
For Each c In ActiveSheet.UsedRange
If c.Interior.Color <> IntColor Then objArrLst.Add _
Right(String(fLen + 1, Chr(32)) & c.Formula, fLen) _
& c.CurrentRegion.Address
Next c
objArrLst.Sort
End Sub