Sub ReorderEachRow() ' ' ReorderEachRow Macro ' ' Dim a As Range, b As Range Set a = Selection For Each b In a.Rows Range(b.Address).Select ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(b.Address) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.Sort .SetRange Range(b.Address) .Header = xlGuess .MatchCase = False .Orientation = xlLeftToRight .SortMethod = xlPinYin .Apply End With Next End Sub