Sort data by rows

Question

I have a spreadsheet with many numbers, and I want the cells with the same numbers to be moved to the same row. Currently, my spreadsheet looks something like this:

*  May     Jun     Jul     Aug     Sep     Oct
* 10584   10589   10584   10584   10589   10589
* 10589   11202   10589   10589   11202   11202
* 11202   9799    11202   11202   11677   11677
*                         11677     

I would like to have some vba code to organize the data so that cells with the same value are on the same row, so it should look like this:

*  May     Jun     Jul     Aug     Sep     Oct
*         9799
* 10584           10584   10584  
* 10589   10589   10589   10589   10589   10589
* 11202   11202   11202   11202   11202   11202
*                         11677   11677   11677

With empty cells in the places with no numbers. I tried searching through the forum but I wasn't able to find anything similiar enough. I would really apreciate any help on this. Thanks for your time.

Answer 1

Here is another approach that, if you have a large amount of data, should run more quickly, as it only reads and writes to/from the worksheet once -- all the "work" is done within VBA.

You will probably want to move the results to a different worksheet -- all you need to do is change what you Set wsRes and possible rRes

• Create a User defined object which consists of the "Number" and a collection of the columns in which that number appears.

• Read the source data into an array

• iterate through the array, making a collection of unique numbers and all of the columns in which those number appear.
• Sort the objects by number.
• Write the results to an array
• Write the array to the worksheet

You must RENAME the Class Module cNumCols

Class Module

Option Explicit
Private pNum As Long
Private pCOL As Long
Private pCOLs As Collection

Private Sub Class_Initialize()
    Set pCOLs = New Collection
End Sub

Public Property Get Num() As Long
    Num = pNum
End Property
Public Property Let Num(Value As Long)
    pNum = Value
End Property

Public Property Get COL() As Long
    COL = pCOL
End Property
Public Property Let COL(Value As Long)
    pCOL = Value
End Property

Public Property Get COLs() As Collection
    Set COLs = pCOLs
End Property

Public Sub ADD(COLval As Long)
    pCOLs.ADD COLval
End Sub

Regular Module

Option Explicit
Sub SortNumbers()
    Dim cNC As cNumCols, colNC As Collection
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim i As Long, J As Long


'Set source and destination sheets and ranges
Set wsSrc = Worksheets("sheet4")
Set wsRes = Worksheets("sheet4")
    Set rRes = wsRes.Range("L1")

With wsSrc
    vSrc = .Range("a1").CurrentRegion
End With

'collect list of unique numbers, along with their columns
Set colNC = New Collection
On Error Resume Next
For i = 2 To UBound(vSrc, 1)
    For J = 1 To UBound(vSrc, 2)
        If vSrc(i, J) <> "" Then
            Set cNC = New cNumCols
            With cNC
                .Num = vSrc(i, J)
                .COL = J
                .ADD .COL
                colNC.ADD cNC, CStr(.Num)
                If Err.Number = 457 Then
                    Err.Clear
                    colNC(CStr(.Num)).ADD .COL
                End If
                If Err.Number <> 0 Then 'stop to debug error
                    Debug.Print Err.Source, Err.Number, Err.Description
                    Stop
                End If
            End With
        End If
    Next J
Next i
On Error GoTo 0

'Sort collection by number
CollectionBubbleSort colNC, "Num"

'Populate results array
ReDim vRes(0 To colNC.Count, 1 To UBound(vSrc, 2))

'header row
For J = 1 To UBound(vSrc, 2)
    vRes(0, J) = vSrc(1, J)
Next J

'data
For i = 1 To colNC.Count
    With colNC(i)
        For J = 1 To .COLs.Count
            vRes(i, .COLs(J)) = .Num
        Next J
    End With
Next i

'Clear results area and write results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

'Could use faster sort routine if necessary
Sub CollectionBubbleSort(TempCol As Collection, Optional Prop As String = "")
    Dim i As Long
    Dim NoExchanges As Boolean

    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True

        ' Loop through each element in the array.
        For i = 1 To TempCol.Count - 1

If Prop = "" Then

            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If TempCol(i) > TempCol(i + 1) Then
                NoExchanges = False
                TempCol.ADD TempCol(i), after:=i + 1
                TempCol.Remove i
            End If
Else
        If CallByName(TempCol(i), Prop, VbGet) > CallByName(TempCol(i + 1), Prop, VbGet) Then
                NoExchanges = False
                TempCol.ADD TempCol(i), after:=i + 1
                TempCol.Remove i
            End If
End If
        Next i
    Loop While Not (NoExchanges)
End Sub

Answer 2

Here is an approach that works on a block of data of arbitrary size. It works by sorting the columns and then shifting the cells down if they are not equal to the smallest value in the row.

The only real parameter here to adjust is the starting cell: rng_start which is initially set to the ActiveCell. This code also uses CurrentRegion so the data needs to be a block... or you can redefine those couple of lines.

Code

Sub SortAndPutSameValuesInSameRow()

    'get data ranges
    Dim rng_start As Range
    Set rng_start = ActiveCell

    Dim rng_data As Range
    Set rng_data = rng_start.CurrentRegion
    Set rng_data = Intersect(rng_data, rng_data.Offset(1))

    'sort by column
    Dim rng_col As Range
    For Each rng_col In rng_data.Columns
        rng_col.Sort Key1:=rng_col
    Next

    'iterate through rows and arrange
    Dim rng_row As Range
    For Each rng_row In rng_data.Rows
        Dim rng_cell As Range
        For Each rng_cell In rng_row.Cells
            If rng_cell.Value <> Application.WorksheetFunction.min(rng_row) Then
                rng_cell.Insert xlShiftDown
            End If
        Next

        'break out if cell goes past data
        If Intersect(rng_row, rng_start.CurrentRegion) Is Nothing Then
            Exit For
        End If
    Next
End Sub

How it works

The main idea here is that once the columns are sorted, you just need to move values down so that only the smallest value is kept in each row. This logic also ensures that all of the same values are in the same row. Note that if there are duplicate values, you will get a row of matching values and then duplicate values (which would also match if repeated in multiple columns). Specific comments:

• The top half of the code is setting things up for the iteration section below. It grabs the block of data and builds a range that excludes the headers.
• With the block of data, it first goes through each column and sorts them in turn.
• Once sorted, it goes through each row of the data and checks if the current value is equal to the minimum value in the row.
• If so, then that cell can stay put. If not, the values need to shift down to make a blank cell.
• Finally, there is a check to bust out of the loop when needed. This is a little odd in a For Each loop but is required because the size of the range is changing as it iterates (because of Insert).

Since I am using Rows and Columns, this code will work for data anywhere on the sheet and for as many columns as you want.

Pictures of before/after show results with your data

before

after

Answer 3

This should work:

Sub t()
Dim i As Integer, min As Long, rowCurrent As Integer
Dim j As String
For i = 1 To 6
'sort all the columns first
    Columns(i).Sort key1:=Cells(2, i), _
    order1:=xlAscending, Header:=xlYes
Next i
rowCurrent = 2
While Not Application.WorksheetFunction.Sum(Range("A" & rowCurrent & ":F" & rowCurrent)) = 0
    min = Application.WorksheetFunction.min(Rows(rowCurrent))
    For i = 1 To 6
        If Cells(rowCurrent, i) <> min Then
            Range(Cells(rowCurrent, i).Offset(1, 0).Address & ":" & Cells(Rows.Count, i).End(xlUp).Offset(1, 0).Address).Value = _
            Range(Cells(rowCurrent, i).Address & ":" & Cells(Rows.Count, i).End(xlUp).Address).Value
            Cells(rowCurrent, i).Value = ""
        End If
    Next i
    rowCurrent = rowCurrent + 1
Wend
End Sub