Why the records fetching multiple times (1 Viewer)

Public Sub InsertDates():
  Dim objXl As Excel.Application
  Dim objWkb As Excel.Workbook
  Dim objSht As Excel.Worksheet
  Dim rstNames As DAO.Recordset, rst As DAO.Recordset
  Dim iRow As Integer, x As Long
  Dim PreviousDate As Date, MonthEndDate As Date
 
  '==
Dim TempDate, TTempDate, DummyDate, CheckTime, DCheckTime
Dim MyDay As Integer
Dim MAM, MPM
Dim InTime, OutTime
Dim DAccNo, TAccNo As Double
Dim Cmprdate
Dim CmprInTime
Dim CmprOutTime
Dim DEmp, TEmp As String
Dim MN As String
Dim Yr As Variant
Dim Interval As Variant
Dim dblNumHours As Double

Dim Q As String
  '==
 
 
  Set rstNames = CurrentDb.OpenRecordset("SELECT DISTINCT VehicleNo, VEDate FROM Q1;")
  If rstNames.EOF And rstNames.BOF Then
    MsgBox ("No Records In This Month"), vbInformation, "Null Records Inf."
  Else
    Set objXl = New Excel.Application
    objXl.Visible = True
    Set objWkb = objXl.Workbooks.Open("D:\VehicleDB\VehExpReport\VehExpReport.xlsx")
   
    Do
      Set objSht = objWkb.Worksheets.Add()
      objWkb.ActiveSheet.Name = rstNames![VehicleNo]
     
      Set rst = CurrentDb.OpenRecordset("SELECT [T_VehExp.VehicleNo], [T_VehExp.VEDate], [T_VehExp.JobNo], " & _
      "[T_VehExp.InvoiceNo], [T_VehExp.VehicleModel], [T_VehExp.VDate], [T_VehExp.Expense Description], [T_VehExp.Amount], " & _
      "[T_VehExp.KM], [T_VehExp.Remarks], [T_VehExp.Part], [T_VehExp.MechanicName] FROM T_VehExp " & _
      "WHERE [T_VehExp.VehicleNo] ='" & rstNames![VehicleNo] & "' ;")

Q = rstNames![VehicleNo]

     
      If rst.EOF And rst.BOF Then
        MsgBox ("No Records In This Month"), vbInformation, "Null Records Inf."
      Else
Call FormatSheet(objSht, "VehicleNo:" & " - " & rst![T_VehExp.VehicleNo])
       
        iRow = 5
        rst.MoveFirst
       
        Do While Not rst.EOF
         
'
          objSht.Cells(iRow, 1).Value = DateValue(rst![T_VehExp.VEDate])
          objSht.Cells(iRow, 1).HorizontalAlignment = xlCenter
          objSht.Cells(iRow, 1).Borders.Color = vbBlack
          objSht.Cells(iRow, 2).Value = rst![T_VehExp.JobNo]
          objSht.Cells(iRow, 2).HorizontalAlignment = xlCenter
          objSht.Cells(iRow, 2).Borders.Color = vbBlack
          If (IsNull(rst![T_VehExp.InvoiceNo])) Then
          Dim Z As Integer
          Z = 0
          objSht.Cells(iRow, 3).Value = Z
          Else
          objSht.Cells(iRow, 3).Value = TimeValue(rst![T_VehExp.InvoiceNo])
          End If
          objSht.Cells(iRow, 3).Borders.Color = vbBlack


'===
          iRow = iRow + 1
          rst.MoveNext
        Loop
'   objWkb.ActiveSheet.Name = rstNames![VehicleNo]
       
        rst.MoveLast
''====
'            'objSht.Cells(iRow, 7).Value = "Date Created"
'
'            x = x + 1
'            iRow = iRow + 1
'        End If
       
'          Loop Until rstNames![VehicleNo] = rst![T_VehExp.VehicleNo]
'        End If
      End If
      rstNames.MoveNext
    Loop Until rstNames.EOF
      
    objXl.Application.DisplayAlerts = False
    objWkb.Worksheets("Sheet1").Delete
    objXl.Application.DisplayAlerts = True
  End If
End Sub