Repeat Sort Macro for Paired Rows Down Entire Sheet

Tallonenx

New Member
Joined
Nov 30, 2017
Messages
12
Hi all, trying to sort dates and events on those dates which are in two rows like so:
4/2/20166/3/20167/7/20151/2/20166/6/20166/15/2016
AAACCC

<tbody>
</tbody>

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:
7/7/20151/2/20164/2/20166/3/20166/6/20166/15/2016
AAACCC

<tbody>
</tbody>


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:
Code:
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!
 

Some videos you may like

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,960
Office Version
  1. 365
Platform
  1. Windows
Hi, welcome to the board
How about
Code:
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

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,407
Maybe...

Code:
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

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,407
Better version

Code:
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

New Member
Joined
Nov 30, 2017
Messages
12

ADVERTISEMENT

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/20161/2/2016
1/2/2016
1/3/20161/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/20161/2/2016
1/3/20161/4/2016
AAA


<tbody>
</tbody>


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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,960
Office Version
  1. 365
Platform
  1. Windows
If the repeat date is always AFTER the event try this mod to Marcelo Branco' code
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

New Member
Joined
Nov 30, 2017
Messages
12

ADVERTISEMENT

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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,960
Office Version
  1. 365
Platform
  1. Windows
Ok, try this
Code:
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

New Member
Joined
Nov 30, 2017
Messages
12
Hmmm...
That didn't seem to work.
It deleted cells after the duplicate date but not the right cells.
 

Marcelo Branco

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,407
See if this does what you need

Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,561
Messages
5,596,849
Members
414,107
Latest member
Tigretto

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top