Add to list without removing values Q

[Blsgw]

Hello everyone!

Currently using the code:

Sub CopySheet()
Dim LR As Long
With Sheets("New Brand Template")
    LR = WorksheetFunction.Max(2, .Range("A" & Rows.Count).End(xlUp).Row + 1)
    Sheets("New Brand Page").Range("C5").Copy Destination:=Sheets("Brands").Range("A" & LR)
    Sheets("Brands").Range("A2:A" & LR).Sort Key1:=Sheets("Brands").Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    .Copy after:=Worksheets(Worksheets.Count)
End With
ActiveSheet.Name = Sheets("New Brand Page").Range("C5").Value
End Sub

What it is doing is copying a sheet named New Brand Template, sending it to the end of my workbook, renaming it with the value in C5 of New Brand Page, then adding the name of the new sheet to a list in 'Brands' starting at A2.

Now all of this works as I want it to, but... its not allowing me to expand the list in A2 of Brands... I want it to add it to the list starting there, but multiple brands will be added, at the moment, it will just delete A2 and put the newest brand in, instead of basically shifting A2 down to A3 and putting the newest in A2.

Now how can I modify my code to allow this, and preferable sort that list in A2:A from A-Z?

Thanks guys in advance