hocam çok teşekkür ederim seruz hocanın bu örnek formülünü uyarlayabilirmiyiz acaba?
Option Compare Database 'Use database order for string comparisons
Option Explicit
Dim ExcelDosyasi As Object

Private Sub BasTarihi_AfterUpdate()
Me.BitTarihi = Me.BasTarihi + 6
End Sub

Private Sub btn_EXCEL_Click()
On Error GoTo Err_btn_EXCEL_Click
Dim Rs As New ADODB.Recordset
Dim i, BasSatirSayisi, SatirSayisi, SutunSayisi As Integer

If IsNull(Me.Secilen_MAHALLE) Then Exit Sub

'---------------------------------------------------------------------------------------------------------
'Excel açılıyor ve başlıklar ayarlanıyor
'---------------------------------------------------------------------------------------------------------
Set ExcelDosyasi = CreateObject("Excel.Application")
With ExcelDosyasi
.Application.Visible = True
.UserControl = True
.Workbooks.Add
.Sheets(1).Name = Me.Secilen_MAHALLE
End With

'---------------------------------------------------------------------------------------------------------
'Tablo açılıyor
'---------------------------------------------------------------------------------------------------------
DoCmd.SetWarnings False
DoCmd.OpenQuery "HAFTALIK_Yarat"
DoCmd.SetWarnings False

'---------------------------------------------------------------------------------------------------------
'Tablo açılıyor
'---------------------------------------------------------------------------------------------------------
Rs.Open "HAFTALIK_Capraz", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
SutunSayisi = Rs.Fields.Count
BasSatirSayisi = 3
SatirSayisi = BasSatirSayisi

'Başlıklar Oluşturuluyor
With ExcelDosyasi
.Sheets(1).Select
.ActiveWindow.DisplayGridlines = False
.Cells(1, 2) = Me.Secilen_MAHALLE & " BELDESİ HAFTALIK ÇALIŞMA PROGRAMI"
.Cells.Font.Name = "Arial"
.Cells.Font.Size = 20

'Kayıt yoksa çıkılıyor
If Rs.RecordCount = 0 Then
.Cells(2, 2) = "Kayıt bulunamadı"
Rs.Close
Exit Sub
End If

'Sütun Başlıkları atanıyor, Tarih olan alanların formatı değiştiriliyor.
For i = 1 To SutunSayisi
If Rs.Fields(i - 1).Name = "Saat" Then
.Cells(SatirSayisi, i + 1) = Rs.Fields(i - 1).Name
Else
.Cells(SatirSayisi, i + 1) = CVDate(Rs.Fields(i - 1).Name)
.Cells.NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
End If
Next i
End With

'---------------------------------------------------------------------------------------------------------
' Kayıtlar Okunuyor ve Yazılıyor
'---------------------------------------------------------------------------------------------------------
Do Until Rs.EOF
With ExcelDosyasi
SatirSayisi = SatirSayisi + 1

'Satır Detayı
For i = 1 To SutunSayisi
.Cells(SatirSayisi, i + 1) = Rs.Fields(i - 1)
Next i

'Sonraki Kayıt
Rs.MoveNext
End With
Loop
Rs.Close

'-----------------------------------------------------------------------
' Sütun Formatları
'-----------------------------------------------------------------------
With ExcelDosyasi
.Range(.Cells(3, 2).Address, .Cells(SatirSayisi, SutunSayisi + 1).Address).HorizontalAlignment = xlCenter
.Cells.EntireColumn.AutoFit
.Columns("A").EntireColumn.ColumnWidth = 1
.Columns("B").EntireColumn.ColumnWidth = 11

' Çerçeve İşlemleri
.Range(.Cells(3, 2).Address, .Cells(SatirSayisi, SutunSayisi + 1).Address).Select

.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

' Yazıcı Ayarları
With .ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
.ActiveSheet.PageSetup.PrintArea = ""
With .ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = .Application.InchesToPoints(0.4)
.RightMargin = .Application.InchesToPoints(0.4)
.TopMargin = .Application.InchesToPoints(0.4)
.BottomMargin = .Application.InchesToPoints(0.4)
.HeaderMargin = .Application.InchesToPoints(0.4)
.FooterMargin = .Application.InchesToPoints(0.4)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
End With
'-----------------------------------------------------------------------

ExcelDosyasi.Range("A1").Select

Set ExcelDosyasi = Nothing

Exit_btn_EXCEL_Click:
Exit Sub

Err_btn_EXCEL_Click:
MsgBox Err.Description
Resume Exit_btn_EXCEL_Click

End Sub