Repeat Sort Macro for Paired Rows Down Entire Sheet

T

Tallonenx

New Member
Joined
Nov 30, 2017
Messages
13
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:
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!
 
Sort by date Sort by votes
Using the data you showed in your op. This is what I get.
1st 2 rows final result
2nd 2rows intermediate result
final 2 rows original data
If you are not getting this, or your data does not look like this. Could you please supply a more representative sample.


Excel 2013 32 bit
ABCDEFGHIJK
107/07/201501/02/201604/02/201606/03/201606/06/20166/15/2016
2AAACCC
3
407/07/201507/07/201501/02/201604/02/201606/03/201606/06/201606/06/20166/15/2016
5AAACCC
6
704/02/201606/03/201607/07/201507/07/201501/02/201606/06/201606/06/20166/15/2016
8AAACCC
Summary
 
Upvote 0

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Hi Dave

Your code failed with this scenario - duplicated to be deleted (blank in the row below) after the first occurrence
Dates as dd/mm/yyyy

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #DCE6F1"][/TD]
[TD="bgcolor: #DCE6F1"]
A​
[/TD]
[TD="bgcolor: #DCE6F1"]
B​
[/TD]
[TD="bgcolor: #DCE6F1"]
C​
[/TD]
[TD="bgcolor: #DCE6F1"]
D​
[/TD]
[TD="bgcolor: #DCE6F1"]
E​
[/TD]
[TD="bgcolor: #DCE6F1"]
F​
[/TD]
[TD="bgcolor: #DCE6F1"]
G​
[/TD]
[TD="bgcolor: #DCE6F1"]
H​
[/TD]
[TD="bgcolor: #DCE6F1"]
I​
[/TD]
[TD="bgcolor: #DCE6F1"]
J​
[/TD]
[TD="bgcolor: #DCE6F1"]
K​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
1​
[/TD]
[TD]
04/02/2016​
[/TD]
[TD]
06/03/2016​
[/TD]
[TD][/TD]
[TD]
07/07/2015​
[/TD]
[TD]
07/07/2015​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
01/02/2016​
[/TD]
[TD]
06/06/2016​
[/TD]
[TD]
06/06/2016​
[/TD]
[TD]
15/06/2016​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
2​
[/TD]
[TD]
AAA​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
AAA​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
CCC​
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


It seems my last code (post 10) is working fine. Waiting for the OP...

M.
 
Upvote 0
Hello Marcelo
I'd agree that your solution is more robust than mine & would recommend the OP to use it.
As the OP said that the duplicate dates were always in front of those with events, then mine solution should work as well.
We'll see what the OP has to say.
 
Upvote 0
Great!
Marcelo's code clears the correct cells now..
but leaves the cleared cells as blanks.


I tried to F5 Special --> Delete Blanks, but it deletes all the blanks in the sheet, which won't work.

Somehow the duplicate blanks, and the corresponding row below them, need to be deleted and shifted (to the left?).


Is there a way to do this automated?
Could the code above be used to do this- IE instead of clearing
could it delete and shift to the left the duplicate date and the row below it?

Again, thank you both!
 
Upvote 0
Ok. Thanks Marcelo.

The code clears the cells but does not delete them.

Ex- Current Code Does this:

[TABLE="class: cms_table"]
<tbody>[TR]
[TD]1/1/2016[/TD]
[TD]1/2/2016
[/TD]
[TD]1/2/2016
[/TD]
[TD]1/3/2016[/TD]
[TD]1/4/2016[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]AAA
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
-->
[TABLE="class: cms_table"]
<tbody>[TR]
[TD]1/1/2016[/TD]
[TD]1/2/2016
[/TD]
[TD][Blank]
[/TD]
[TD]1/3/2016[/TD]
[TD]1/4/2016[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]AAA
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



Ideally It Would do This:
[TABLE="class: cms_table"]
<tbody>[TR]
[TD]1/1/2016
[/TD]
[TD]1/2/2016
[/TD]
[TD]1/2/2016
[/TD]
[TD]1/3/2016[/TD]
[TD]1/4/2016[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]AAA
[/TD]
[TD]
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
-->

[TABLE="class: cms_table"]
<tbody>[TR]
[TD]1/1/2016
[/TD]
[TD]1/2/2016
[/TD]
[TD]1/3/2016[/TD]
[TD]1/4/2016[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]AAA
[/TD]
[TD]
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

No Blanks left, but bottom row still corresponding to its respective date.
 
Last edited:
Upvote 0
For me the code (post 10) worked perfectly

Before macro

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #DCE6F1"][/TD]
[TD="bgcolor: #DCE6F1"]
A​
[/TD]
[TD="bgcolor: #DCE6F1"]
B​
[/TD]
[TD="bgcolor: #DCE6F1"]
C​
[/TD]
[TD="bgcolor: #DCE6F1"]
D​
[/TD]
[TD="bgcolor: #DCE6F1"]
E​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
1​
[/TD]
[TD]
01/01/2016​
[/TD]
[TD]
01/02/2016​
[/TD]
[TD]
01/02/2016​
[/TD]
[TD]
01/03/2016​
[/TD]
[TD]
01/04/2016​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
2​
[/TD]
[TD][/TD]
[TD]
AAA​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Macro
Code: 
Sub HorizontalSort()
    Dim rData As Range, i As Long, rCell As Range
    
    Set rData = Range("A1:E2") '<--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

After macro

[TABLE="class: grid"]
<tbody>[TR]
[TD="bgcolor: #DCE6F1"][/TD]
[TD="bgcolor: #DCE6F1"]
A​
[/TD]
[TD="bgcolor: #DCE6F1"]
B​
[/TD]
[TD="bgcolor: #DCE6F1"]
C​
[/TD]
[TD="bgcolor: #DCE6F1"]
D​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
1​
[/TD]
[TD]
01/01/2016​
[/TD]
[TD]
01/02/2016​
[/TD]
[TD]
01/03/2016​
[/TD]
[TD]
01/04/2016​
[/TD]
[/TR]
[TR]
[TD="bgcolor: #DCE6F1"]
2​
[/TD]
[TD][/TD]
[TD]
AAA​
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


M.
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
ActiveX Option Button to sort Data in another sheet and update conbobox
2 3
Replies
22
Views
344
NUC_N_FUTS2
N
E
  • Solved
A little VBA/Macro code adjustment
Replies
3
Views
294
rollis13
rollis13
R
  • Question Question
I keep getting the error 91 but i cant figure out what is wrong here.
Replies
2
Views
60
mumps
mumps
S
  • Question Question
Help with combining 2 macros into 1
Replies
8
Views
270
MARK858
MARK858
R
  • Solved
Retype Macro to run properly
2
Replies
11
Views
144
Alex Blakenburg
A

Forum statistics

Threads
1,224,827
Messages
6,181,194
Members
453,021
Latest member
pingpong7117

Share this page

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
Back
Top