Transferir dados da listbox duas vezes

Tenho uma listbox com dados de uma planilha e não estou conseguindo transferir esses dados para uma outra planilha duas vezes (preciso dos mesmos dados ordenados de duas formas diferentes na mesma planilha).

Este código transfere os dados apenas uma vez. Depois dos dados coloquei de novo o cabeçalho mas não consegui repetir os mesmos dados após este cabeçãolho:



Private Sub CRelatorio_Click()

On Error GoTo Erro

If ListBox1.ListCount <= 1 Then
   MsgBox "Não há dados para Transferir!", vbCritical, "RELATÓRIO"
   Exit Sub
End If

Planilha4.Activate
Planilha4.Range("B4").Select

Planilha4.Range(Selection, Selection.End(xlDown)).Select
Intersect(Selection.EntireRow, Range("B:F")).Select

Selection.ClearContents

Planilha4.Range("B4").Select

Dim linhalistbox As Double, Linha As Double, Numero As Double
Dim Tempo As Date

Linha = 4

For linhalistbox = 1 To ListBox1.ListCount - 1

       On Error Resume Next
       Tempo = ListBox1.List(linhalistbox, 4)
       On Error Resume Next
       Numero = ListBox1.List(linhalistbox, 0)
       
       Planilha4.Cells(Linha, 2) = Numero
       Planilha4.Cells(Linha, 3) = ListBox1.List(linhalistbox, 1)
       Planilha4.Cells(Linha, 4) = ListBox1.List(linhalistbox, 2)
       Planilha4.Cells(Linha, 5) = ListBox1.List(linhalistbox, 3)
       Planilha4.Cells(Linha, 6) = Tempo
       
       Linha = Linha + 1

Next linhalistbox

' Inserir uma quebra de página antes de adicionar o cabeçalho novamente
Planilha4.HPageBreaks.Add Before:=Planilha4.Cells(Linha, 1)

' Adicionar cabeçalho novamente após a última linha preenchida
Planilha4.Rows(3).Copy Planilha4.Rows(Linha)

Linha = Linha + 1

Dim Plan As String
Plan = Planilha4.Name

Planilha4.Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.Worksheets(Plan).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(Plan).Sort.SortFields.Add Key:=Range( _
   "D4:D10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
   xlSortNormal
ActiveWorkbook.Worksheets(Plan).Sort.SortFields.Add Key:=Range( _
   "F4:F10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
   xlSortNormal
With ActiveWorkbook.Worksheets(Plan).Sort
   .SetRange Range("B3:F10000")
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
End With
   
   
   
   
Dim Resposta As Integer
Resposta = MsgBox("DESEJA IMPRIMIR A CLASSIFICAÇÃO GERAL?", VBA.vbYesNo, "EXPORTAR")

If Resposta = VBA.vbYes Then
Módulo2.PDF
End If

Exit Sub
Erro:
MsgBox "Erro!", vbCritical, "ERRO"

End Sub