Dim rsExcel As New ADODB.Recordset, dosya As String
dosya = "Sipariş İzleme Radarı " & Date & ".xls"
 
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
 
'Dim rsExcel As New Recordset
Set vbExcel = CreateObject("Excel.Application")
Set vbBook = vbExcel.Workbooks.Add
 
rsExcel.Open Me.Liste0.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
 
' Excel Belgesine Başlıklar Aktarılıyor
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
'x:
 
Wend
vbSheet.cells.Select
vbSheet.cells.EntireColumn.AutoFit
vbSheet.Range("A1").Select
 
 
vbBook.SaveAs "Sipariş İzleme Radarı " & Date & ".xls"
vbExcel.Quit
 
 
Set dbExcel = Nothing
Set rsExcel = Nothing
Set vbExcel = Nothing
Set vbBook = Nothing
Set vbSheet = Nothing
 
'MsgBox Dosya & " Listesi Belgelerim Klasörüne aktarılmıştır"
 
cvp = MsgBox(dosya & " Listesi Belgelerim Klasörüne aktarılmıştır, acmak istermisiniz?", vbYesNo, "Excel dosyasini")
If cvp = vbYes Then Application.FollowHyperlink "C:\Users\" & Environ("username") & "\Documents\" & dosya, , True, True, , msoMethodGet

...
...
With vbSheet.PageSetup
.LeftMargin = Application.PointstoInch(.25)
.RightMargin = Application.PointstoInch(.25)
.TopMargin = Application.PointstoInch(.25)
.BottomMargin = Application.PointstoInch(.25)
.HeaderMargin =Application.PointstoInch(.25)
.FooterMargin = Application.PointstoInch(.25)
End With
...
...