No text change from a2 to a6 of Column A sheet 1

[luria]

Am currently using a macro that autotransposes the data from sheet 1 to sheet 2.
The sheet that I use transposes first 1000 values from sheet 1 column A to sheet 2 row 2, the next thousand from sheet 1 column A to sheet 2 row 3 and so on.
now, the problem is i wanted first 4 values to always be the same and get transposed to sheet 2 row 2.

For example :
Current macro :
Column A on sheet 1
A1 - Heading (say fruits)
A2 - Orange
A3 - Grapes
A4 - Melon
A5 - Apple
A6 - Berries
A7- Papaya
A8- Strawberry

Result on sheet 2 Row 2 :
Orange,Grapes,Melon,Apple,Berries,Papaya,Strawberry
Now, what am looking for is an addition to the exisitng macro so that, the first 4 values remain the same always(WITHOUTING Having the need for me to hide the first few cells)
So, no matter what is pasted from A6, A2 to A5 should always have the exact same values and then the entire data should get transposed.
Current code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Locked = True Then
Me.Protect Password:="Secret"
Else
Me.Unprotect Password:="Secret"
End If
End Sub
Sub auto_Transpose2()

Dim lDuplicates As Long
Dim lRow1 As Long
Dim lRow2 As Long
Dim lCol1 As Long
Dim lCol2 As Long
Dim iCounter As Integer
lRow1 = 3 'Row 1 & 2 contains headers data to transpose starts on row 2
lRow2 = 2 'We will transpose data to row 2 on sheet 2
lCol1 = 1 'Column A on sheet 1 contains the data to transpose
lCol2 = 1 'Start in Column A on sheet 2 to tanspose data
lDuplicates = 0 'start with 0 duplicates
Application.ScreenUpdating = False 'turn off the screen updating to help run faster.
With Sheets("Sheet1")
'first we need to sort the data on Sheet1 column A
.Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo

'now we copy the first value in the list A2 to sheet 2
Sheets("Sheet1").Cells(lRow2, lCol2) = .Cells(2, lCol1) & "," & .Cells(lRow1, lCol1)
Sheets("Sheet1").Cells(lRow2, lCol2).NumberFormat = "General"
iCounter = 2

'cycle through the list from sheet 1
For lRow1 = 4 To .Cells(.Rows.Count, "A").End(xlUp).Row

If .Cells(lRow1, lCol1) = .Cells(lRow1 - 1, lCol1) Then
lDuplicates = lDuplicates + 1
.Cells(lRow1, lCol1).Interior.ColorIndex = 6
Else

If Sheets("Sheet1").Cells(lRow2, lCol2) <> "" Then
Sheets("Sheet1").Cells(lRow2, lCol2) = Sheets("Sheet1").Cells(lRow2, lCol2) & "," & .Cells(lRow1, lCol1)
Else
Sheets("Sheet1").Cells(lRow2, lCol2) = .Cells(lRow1, lCol1)
Sheets("Sheet1").Cells(lRow2, lCol2).NumberFormat = "General"
End If
iCounter = iCounter + 1
If iCounter = 1000 Then
iCounter = 0
lRow2 = lRow2 + 1
End If
End If

Next lRow1

.Range("E11") = "Duplicate company ids"
.Range("D11") = lDuplicates
.Range("E12") = "Unique company ids"
.Range("D12") = .Cells(.Rows.Count, "A").End(xlUp).Row - lDuplicates - 2
.Range("E13") = "Total company ids"
.Range("D13").Value = .Range("D11").Value + .Range("D12").Value
End With
Application.ScreenUpdating = True 'turn back on the screen updating
Worksheets("Sheet1").Activate
Range("A2").Select
End Sub
Sub transpose_Populate()
'to populate Sheet1 with unique and duplicate data
Dim lRow As Long
Dim lCount As Long
Dim sRow As String
lRow = 1
sRow = "A"
For lCount = 3 To 3503
With Sheets("Sheet1")
.Range("A" & lCount) = lRow ' & sRow
lRow = lRow + 1
If lCount = 1003 Then
sRow = "A"
'lRow = 1
End If
If lCount = 2003 Then
sRow = "A"
'lRow = 1
End If
If lCount = 3003 Then
sRow = "A"
'lRow = 1
End If
End With
Next lCount
End Sub