Repeat Sort Macro for Paired Rows Down Entire Sheet

[Tallonenx]

Hi all, trying to sort dates and events on those dates which are in two rows like so:
[TABLE="width: 500"]
<tbody>[TR]
[TD]4/2/2016[/TD]
[TD]6/3/2016[/TD]
[TD][/TD]
[TD][/TD]
[TD]7/7/2015[/TD]
[TD][/TD]
[TD][/TD]
[TD]1/2/2016[/TD]
[TD]6/6/2016[/TD]
[TD]6/15/2016[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]AAA[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]CCC[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

These rows continue for hundreds of columns, and there are hundreds of row pairings themselves.
Some of the dates have events, others are blanks.
There are some blanks between dates as well.

>Selecting two rows together at a time sorts the row pairs together and keeps the second row events together with their corresponding date.
No problem with empties or anything- Easy enough.

IE the Sort Yields:
[TABLE="width: 500"]
<tbody>[TR]
[TD]7/7/2015[/TD]
[TD]1/2/2016[/TD]
[TD]4/2/2016[/TD]
[TD]6/3/2016[/TD]
[TD]6/6/2016[/TD]
[TD]6/15/2016[/TD]
[/TR]
[TR]
[TD]AAA[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]CCC[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


My question is- how can I automate this two row a piece simple sorting down the entire selection of data/or sheet,
instead of having to select each set of two rows manually?


I tried recording a macro but found I'd have to manually change the selections in it too ex:

Sub TestOrder()
'
' TestOrder Macro
'

'
    Rows("1:2").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:NU1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:NU2")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    Rows("3:4").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A3:NU3") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A3:NU4")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    Rows("5:6").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A5:NU5") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A5:NU6")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

I suppose the solution would be to get rid of the select code and do some looping, but I can't get it to work.
Any help is MUCH appreciated!

 

[Fluff]

Hi, welcome to the board
How about

Sub TestOrder()
'
    Dim Cnt As Long
    
    With Worksheets("Sheet1")
        For Cnt = 1 To Range("A" & Rows.Count).End(xlUp).Row Step 2
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("A" & Cnt).Resize(, 385) _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range("A" & Cnt).Resize(2, 385)
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlLeftToRight
                .SortMethod = xlPinYin
                .Apply
            End With
        Next Cnt
    End With

End Sub

 

[Marcelo Branco]

Maybe...

Sub HorizontalSort()
    Dim rData As Range, i As Long
    
    Set rData = Range("A1:J12") '<--adjust to suit
    For i = 1 To rData.Rows.Count Step 2
        With Range("A" & i & ":J" & i + 1)
            .Sort key1:=.Cells(1), Orientation:=xlSortRows, Header:=xlNo
        End With
    Next i
End Sub

M.

 

[Marcelo Branco]

Better version

Sub HorizontalSort()
    Dim rData As Range, i As Long
    
    Set rData = Range("A1:J12") '<--adjust to suit
    For i = 1 To rData.Rows.Count Step 2
        With rData.Rows(i & ":" & i + 1)
            .Sort key1:=.Cells(1), Orientation:=xlSortRows, Header:=xlNo
        End With
    Next i
End Sub

M.

 

[Tallonenx]

Wow. So quick!
Those worked great- thanks folks.

However, now that I can see things in order I'm faced with another issue-
The dates with event entry in row two also have a repeat blank entry

IE:

1/1/2016	1/2/2016	1/2/2016	1/3/2016	1/4/2016
	AAA

<tbody>
</tbody>

I'd like to remove the rows for the repeat date, but keep the dates before and after.

IE:

1/1/2016	1/2/2016	1/3/2016	1/4/2016
	AAA

<tbody>
</tbody>

I thought remove duplicates would work... but it didn't.
Any ideas?

 

[Fluff]

If the repeat date is always AFTER the event try this mod to Marcelo Branco' code

Sub HorizontalSort()
    Dim rData As Range, i As Long
    
    Set rData = Range("A1:K12") '<--adjust to suit
    For i = 1 To rData.Rows.Count Step 2
        With rData.Rows(i & ":" & i + 1)
            .Sort key1:=.Cells(1), Orientation:=xlSortRows, Header:=xlNo
        End With
        Rows(i + 1).SpecialCells(xlBlanks)(1).Offset(-1).Resize(2).Delete xlToLeft
    Next i
End Sub

 

[Tallonenx]

Actually using the code it puts them BEFORE the event for whatever reason.... sorry!

 

[Fluff]

Ok, try this

Sub HorizontalSort()
    Dim rData As Range, i As Long, Ar As Areas, Rng As Range
    
    Set rData = Range("A1:K12") '<--adjust to suit
    For i = 1 To rData.Rows.Count Step 2
        With rData.Rows(i & ":" & i + 1)
            .Sort key1:=.Cells(1), Orientation:=xlSortRows, Header:=xlNo
        End With
       Set Ar = Rows(i + 1).SpecialCells(xlConstants).Areas
       For Each Rng In Ar
            Rng.Offset(-1, -1).Resize(2).Delete xlToLeft
       Next Rng
    Next i
End Sub

 

[Tallonenx]

Hmmm...
That didn't seem to work.
It deleted cells after the duplicate date but not the right cells.

 

[Marcelo Branco]

See if this does what you need

Sub HorizontalSort()
    Dim rData As Range, i As Long, rCell As Range
    
    Set rData = Range("A1:J12") '<--adjust to suit
    For i = 1 To rData.Rows.Count Step 2
        With rData.Rows(i)
            For Each rCell In .Cells
                If Application.CountIf(.Cells, rCell.Value) > 1 And rCell.Offset(1) = "" Then rCell.ClearContents
            Next rCell
        End With
    
        With Range("A" & i & ":J" & i + 1)
            .Sort key1:=.Cells(1), Orientation:=xlSortRows, Header:=xlNo
        End With
    Next i
End Sub

M.