Не записывается отсортировка в Лист2

Type Worker
    M As String
    S As String
    R As String
    Color As Variant
    Dver As String
    God As String
    C As String
End Type
Sub Worker()
 
Dim WorkArr() As Worker
Dim temp As Worker
Dim Num, N, k, j, S, S2 As Long
 
S = Val(InputBox("Введите нужный цвет"))
If S = 0 Then
'Exit Sub'
S2 = Val(InputBox("Введите нужный год"))
If S2 = 0 Then
Exit Sub
End If
 
Sheets("Лист2").Select
 
N = 3
Num = 0
 
Do While Cells(N, 4) <> Empty
    If Cells(N, 6) >= S And Cells(N, 6) <= S2 Then
        Num = Num + 1
        ReDim Preserve WorkArr(Num)
        WorkArr(Num).M = Cells(N, 1)
        WorkArr(Num).S = Cells(N, 2)
        WorkArr(Num).R = Cells(N, 3)
        WorkArr(Num).Color = Cells(N, 4)
        WorkArr(Num).Dver = Cells(N, 5)
        WorkArr(Num).God = Cells(N, 6)
        WorkArr(Num).C = Cells(N, 7)
    End If
    N = N + 1
Loop
 
For k = 1 To Num - 1
    For j = 1 To Num - k
        If WorkArr(j + 1).Color & WorkArr(j + 1).God < WorkArr(j).Color & WorkArr(j).God Then
            temp = WorkArr(j)
            WorkArr(j) = WorkArr(j + 1)
            WorkArr(j + 1) = temp
        End If
    Next j
Next k
 
Sheets("Лист2").Select
 
Columns("A:G").Clear
 
Cells(1, 1) = "Сведения о автомобилях " & S & "определенного" & " цвета"
Cells(2, 1) = Worksheets("Лист2").Cells(2, 1)
Cells(2, 2) = Worksheets("Лист2").Cells(2, 4)
Cells(2, 3) = Worksheets("Лист2").Cells(2, 5)
Cells(2, 4) = Worksheets("Лист2").Cells(2, 6)
 
N = 3
For k = 1 To Num
    Cells(N, 1) = WorkArr(k).M
    Cells(N, 2) = WorkArr(k).Color
    Cells(N, 3) = WorkArr(k).God
    Cells(N, 4) = WorkArr(k).C
    
    N = N + 1
Next k
 
Columns("A:G").AutoFit
  End If
End Sub

Sub macro1()
Set objConnection = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.Path & "/" & ActiveWorkbook.Name & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
Dim i&, j&
i = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
S = "": S2 = 0: asd = ""
S = InputBox("Введите нужный цвет")
S2 = Val(InputBox("Введите нужный год"))
If S <> "" Then asd = "and  a2.f4='" & S & "'"
If S2 <> 0 Then asd = asd & " and a2.f6=" & S2
If Len(asd) > 0 Then asd = " Where " & Mid(asd, 6)
sqlStr1 = "SELECT a2.f1, a2.f4, a2.f5, a2.f6, a2.f7 from [Лист1$a2:g" & i & "] as a2" & asd
rs.Open sqlStr1, objConnection, 3, 3
Sheets("Лист2").Cells(1, 1) = "Сведения о автомобилях "
Sheets("Лист2").Cells(2, 1) = "Марка"
Sheets("Лист2").Cells(2, 2) = "цвет"
Sheets("Лист2").Cells(2, 3) = "количество дверей"
Sheets("Лист2").Cells(2, 4) = "год выпуска"
Sheets("Лист2").Cells(2, 5) = "Стоимость"
Sheets("Лист2").Cells(3, 1).CopyFromRecordset rs
Set rs = Nothing
Set objConnection = Nothing
End Sub