kusura bakmayın yanlışlıkla A2 yerine A1 yazmışım kodu aşağıdaki gibi düzenleyip dener misiniz?
ilk ' Excel Belgesine Başlıklar Aktarılıyor ile vbExcel.Quit arası alındı bu satırlar da dahil

' Excel Belgesine Başlıklar Aktarılıyor

Set vbSheet = vbBook.Worksheets(1)



For Each fld In rsExcel.Fields

    x = x + 1

    vbSheet.Cells(1, x) = fld.Name

Next fld



vbSheet.Range("A1").Resize(1, x).Font.Color = &HFF0000

vbSheet.Range("A2").CopyFromRecordset rsExcel



vbSheet.Range("A1").Select

vbSheet.Cells.EntireColumn.AutoFit

 

vbBook.SaveAs "D:\Desktop\Dokumaya Gönderilen-" & Date & ".xlsx"

vbExcel.Quit