Dim rsExcel As New ADODB.Recordset, dosya As String
dosya = "belge1"
Dim dbSurucu As String
Dim dbDosya As String
Dim dbExcel As Object
Dim fdExcel As Object
Dim vbExcel As Object
Dim vbBook As Object
Dim vbSheet As Object
Set vbExcel = CreateObject("Excel.Application")
Set vbBook = vbExcel.Workbooks.Add
rsExcel.Open Me.Liste60.RowSource, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
Set vbSheet = vbBook.Worksheets(1)
Dim fdArray, fdCount, rdCount
fdCount = 0
For Each fdExcel In rsExcel.Fields
fdCount = fdCount + 1
If fdCount > 1 Then
fdArray = fdArray & "<,>" & fdExcel.Name
Else
fdArray = fdExcel.Name
End If
Next
With vbSheet.Range("A1")
.Resize(1, fdCount) = Split(fdArray, "<,>")
.Resize(1, fdCount).Font.Color = &HFF0000
End With
rdCount = 1
While Not rsExcel.EOF
rdCount = rdCount + 1
fdCount = 0
For Each fdExcel In rsExcel.Fields
fdCount = fdCount + 1
vbSheet.Cells(rdCount, fdCount) = fdExcel.Value
Next
rsExcel.MoveNext
Wend
vbSheet.Cells.Select
vbSheet.Cells.EntireColumn.AutoFit
vbSheet.Range("A1").Select
vbBook.SaveAs
vbExcel.Quit
Set dbExcel = Nothing
Set rsExcel = Nothing
Set vbExcel = Nothing
Set vbBook = Nothing
Set vbSheet = Nothing

Application.Dialogs(xlDialogSaveAs).Show

'vbBook.SaveAs

    Dim DosyaKayit As FileDialog
    Set DosyaKayit = Application.FileDialog(msoFileDialogSaveAs)
    With DosyaKayit
        .InitialFileName = "C:\Kitap1.xlsx"
        .Show
    End With

vbExcel.Quit
Set DosyaKayit = Nothing