Automate Sorting Row Vertically

[KatieB24]

Is there a way to automate the sorting of a row a-z ascending but across not down. I add a new column in once a week and use a script to make it quicker however i was hoping i could always ensure the row is organised ascendingly without having to do anything?

For example

Row 1 Week1 Week2 Week3 Week4
I would like these columns to remain in order so when i add a new column for example week5 no matter where i insert the column it can update to ensure week 5 goes to the end?

 

[kvsrinivasamurthy]

click inside the data range.
Select Data-->Sort
In dialogue box select Options --> Sort left to right
Select Row1. Ok

 

[KatieB24]

Thankyou for your response. I know how to sort. I am asking is there a way to automate it so that it always occurs not when i manually have to do it

 

[kvsrinivasamurthy]

Worksheet event VBA code enclosed.
Start Cell for week number entry is taken as B1. Change if required.
Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("1:1")) Is Nothing Then
If Target.Cells.Count > 1 Then Exit Sub
On Error GoTo Line1
Application.EnableEvents = False
Dim Lc&, Lr&, clms&, S$, Stcel As Range, Cel As Range
Set Stcel = Range("B1")
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
clms = Lc - Stcel.Column + 1
Lr = Range("A" & Rows.Count).End(xlUp).Row
K = InStr(1, Stcel, " ") + 1
S = Left(Stcel, K - 1)
For Each Cel In Range("b1").Resize(1, clms)
Cel.Value = Val(Mid(Cel, K))
Next

ActiveSheet.Sort.SortFields.Clear
 ActiveSheet.Sort.SortFields.Add2 Key:=Stcel.EntireRow _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Stcel.Resize(Lr, clms)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
For Each Cel In Range("b1").Resize(1, clms)
Cel.Value = S & Cel
Next
Line1:
Application.EnableEvents = True
End If
End Sub

How to use worksheet event the code
Right click on Sheet tab --> view code
Visual Basic (VB) window opens.
Paste the code
Close the VB window.
Save the file as .xlsm

 

[Fuji]

To Sheet code module

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim s$, e$, x, i&, ii&, temp, r As Range
    If Target.Row > 1 Then Exit Sub
    s = [iferror(substitute(address(1,min(if(left(1:1,2)="WK",column(1:1))),4),1,""),"")]
    e = [iferror(substitute(address(1,max(if(left(1:1,2)="WK",column(1:1))),4),1,""),"")]
    If (s = "") + (e = "") + (s = e) Then Exit Sub
    Application.EnableEvents = False
    Set r = Intersect(UsedRange, Columns(s & ":" & e))
    x = r.Rows(1).Value
    For i = 1 To UBound(x, 2) - 1
        For ii = i + 1 To UBound(x, 2)
            If Val(Mid$(x(1, i), 3)) > Val(Mid$(x(1, ii), 3)) Then
                temp = x(1, i): x(1, i) = x(1, ii): x(1, ii) = temp
            End If
    Next ii, i
    With Me.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=r.Rows(1), Order:=1, _
        CustomOrder:=Join(Application.Transpose(Application.Transpose(x)), ",")
        .SetRange r
        .Orientation = 2
        .Apply
    End With
    Application.EnableEvents = True
End Sub