Copy, Paste, Tidy macro help

G'day.
A while ago JBeaucaire provided me with code for a macro that copied data from one sheet, pasted it into another sheet, deleted empty and duplicate cells and sorted the results. I tweaked the code to get it to work in my work book and ended up with the following code:

Option Explicit

Sub MakeList()
Dim LR As Long, LC As Long, i As Long
LR = Range("AA4").SpecialCells(xlCellTypeLastCell).Row
LC = Range("AA4").SpecialCells(xlCellTypeLastCell).Column
Application.ScreenUpdating = False

'Copy all data to second sheet in one column
    For i = 26 To LC
        Range(Cells(2, i), Cells(LR, i)).Copy _
            Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
    Next i

'Clear out null cells and sort
    Sheets("Sheet1").Activate
    Range("A1") = "List"
    Range("B1") = "Key"
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2:B" & LR).FormulaR1C1 = "=OR(RC1="" "",RC1="""")"
    Range("A2").AutoFilter Field:=2, Criteria1:="TRUE"
    Range("A2:B" & LR).SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
    
'Cleanup
    Rows("1:1").Delete
    Columns("B:B").ClearContents
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo
    Range("A1:A" & LR).RemoveDuplicates Columns:=1, Header:=xlNo
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Can anyone tell me how to make the code paste the first result into cell A2 so I can have a title in cell A1. I'm sure it is very easy, I just don't know how to do it.

Cheers

Try this, it will clear the existing Headstamp ID sheet and reinsert a new, unduplicated, sorted set of values in column A. You'll have to add the column B and C stuff since none of that exists anywhere in the original data.

Option Explicit

Sub MakeList()
Dim LR As Long, LC As Long, i As Long
Application.ScreenUpdating = False

Sheets("Headstamp ID").Range("A2:C" & Rows.Count).ClearContents
Sheets("Headstamp Table").Activate
LR = Range("AA4").SpecialCells(xlCellTypeLastCell).Row
LC = Range("AA4").SpecialCells(xlCellTypeLastCell).Column

'Copy all data second sheet
    For i = 1 To LC
        Range(Cells(2, i), Cells(LR, i)).Copy _
            Sheets("Headstamp ID").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Next i

'Clear out null cells and duplicates and sort
    Sheets("Headstamp ID").Activate
    Range("A1:A" & LR).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2:B" & LR).FormulaR1C1 = "=OR(RC1="" "",RC1="""",RC1=0,COUNTIF(R1C1:RC1,RC1)>1)"
    Range("A1").AutoFilter Field:=2, Criteria1:="TRUE"
    On Error Resume Next
    Range("A2:B" & LR).SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
    On Error GoTo 0
    
'Cleanup
    Range("A1").AutoFilter
    Range("B2:B" & Rows.Count).ClearContents
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Actually, now that I thought about it, I realized you might want to KEEP the existing Manufacturer and Country entries each time you rerun the sheet to create a new listing of Headstamps. Yes?

If so, use this version. It will backup the existing Headstamp ID sheet, create a new one with new a new list of IDs and then fit the old B & C values back into the sheet from the backup sheet.

Option Explicit

Sub MakeList()
Dim LR As Long, LC As Long, i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Backup existing ID info
    Sheets("Headstamp ID").Copy After:=Sheets(Sheets.Count)
    Sheets("Headstamp ID (2)").Name = "Backup"
    Sheets("Headstamp ID").Range("A2:C" & Rows.Count).ClearContents

'Copy all data to second sheet
    Sheets("Headstamp Table").Activate
    LR = Range("AA4").SpecialCells(xlCellTypeLastCell).Row
    LC = Range("AA4").SpecialCells(xlCellTypeLastCell).Column

    For i = 1 To LC
        Range(Cells(2, i), Cells(LR, i)).Copy _
            Sheets("Headstamp ID").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Next i

'Find null cells and duplicates, delete them
    Sheets("Headstamp ID").Activate
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2:B" & LR).FormulaR1C1 = "=OR(RC1="" "",RC1="""",RC1=0,COUNTIF(R1C1:RC1,RC1)>1)"
    Range("A1").AutoFilter Field:=2, Criteria1:="TRUE"
    On Error Resume Next
    Range("A2:B" & LR).SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
    On Error GoTo 0
    
'Insert existing infor from backup
    Range("A1").AutoFilter
    LR = Range("A" & Rows.Count).End(xlUp).Row
    With Range("B2:C" & LR)
        .FormulaR1C1 = "=IF(ISERROR(INDEX(Backup!C,MATCH(RC1,Backup!C1,0))),"""",IF(INDEX(Backup!C,MATCH(RC1,Backup!C1,0))=0,"""",INDEX(Backup!C,MATCH(RC1,Backup!C1,0))))"
        .Value = .Value
    End With
    
    With Range("A1:C" & LR)
        .HorizontalAlignment = xlCenter
        .Columns.AutoFit
        .Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortTextAsNumbers
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlThick
    End With
    
'Cleanup
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Sheets("Backup").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

This line of code:

For i = 1 To LC

...means start in column "1" and go to the last column (LC), so just change the 1 to a 2.