Modify the code which to transfer from one Page to Multiple Pages by Page Name

[Hany ali]

Hello my Dear i want to Help me to modify this code to be the Result are you sea in Photo without duplicate for the Same Transfer Type in Differant Row if it's in the Same Date even the Differat in Car Type as Bus ,Hiace ,Coaster ....etc

Sub Test()
    Dim x, y, ws As Worksheet, sh As Worksheet, rng As Range, r As Long, m As Long
        UseSpeedyCode True
        Set ws = ThisWorkbook.Worksheets("Main")
        For r = 3 To ws.Cells(Rows.Count, 1).End(xlUp).Row
            If Evaluate("ISREF('" & ws.Cells(r, 3).Value & "'!A1)") Then
                 Set sh = ThisWorkbook.Worksheets(ws.Cells(r, 3).Value)
                 m = sh.Cells(Rows.Count, 18).End(xlUp).Row + 1
                 sh.Cells(m, 1).Value = ws.Cells(r, 1).Value
                 sh.Cells(m, 18).Value = ws.Cells(r, 2).Value
                 sh.Cells(m, 19).Resize(1, 2).Value = ws.Cells(r, 7).Resize(1, 2).Value
                  x = Application.Match(ws.Cells(r, 5).Value, sh.Rows(1), 0)
                 If Not IsError(x) Then
                    Set rng = sh.Cells(1, x).Offset(1, -1).Resize(1, 4)
                    y = Application.Match(ws.Cells(r, 6).Value, rng, 0)
                    If Not IsError(y) Then
                        sh.Cells(m, x + y - 2).Value = ws.Cells(r, 4).Value
                    End If
                 End If
                End If
            End If
        Next r
    UseSpeedyCode False
    
    MsgBox "Done...", 64
End Sub

Public Function UseSpeedyCode(goFast As Boolean)
    Dim calc As Long
    With Application
        .ScreenUpdating = Not goFast
        .EnableEvents = Not goFast
        If goFast Then
            calc = .Calculation
            .Calculation = xlCalculationManual
        Else
            .Calculation = calc
        End If
    End With
End Function