excele aktar kodunu aşağıdaki gibi düzenleyip dener misiniz?

Private Sub kmtexcel_Click()

Dim rs As Excel.Application

Dim KTP1 As Excel.Workbook

Dim SYF As Excel.Worksheet



DoCmd.SetWarnings False

If IsNull(Me.DtDonem) Or IsNull(Me.DtDonem) Then

MsgBox "Nöbet Dönemi Seçmediniz.", vbCritical + vbDefaultButton1, "UYARI"

Exit Sub

End If



xSQL = "SELECT Tblogretmen.ogretmenadisoyadi, TblNobet.G1, TblNobet.G2, TblNobet.G3, TblNobet.G4, TblNobet.G5, TblNobet.G6, TblNobet.G7, " & _

       "TblNobet.G8, TblNobet.G9, TblNobet.G10, TblNobet.G11, TblNobet.G12, TblNobet.G13, TblNobet.G14, TblNobet.G15, TblNobet.G16, " & _

       "TblNobet.G17, TblNobet.G18, TblNobet.G19, TblNobet.G20, TblNobet.G21, TblNobet.G22, TblNobet.G23, TblNobet.G24, TblNobet.G25, " & _

       "TblNobet.G26, TblNobet.G27, TblNobet.G28, TblNobet.G29, TblNobet.G30, TblNobet.G31, TblNobet.TOPLAM " & _

       "FROM TblNobet INNER JOIN Tblogretmen ON TblNobet.OgretmenId = Tblogretmen.Ogretmen_ID " & _

       "WHERE (((Format([donem],""mmmm yyyy""))='" & Me.DtDonem & "'));"

Set rs2 = CurrentDb.OpenRecordset(xSQL) '"TblNobet_gecici")

If rs2.RecordCount = 0 Then MsgBox "veri bulunamadı": Exit Sub



If MsgBox("Bilgileriniz Excele Aktarılsın mı?", vbCritical + vbYesNo + vbDefaultButton1, "UYARI") = vbNo Then Exit Sub

MsgBox "Aktarma İşlemi BİP sesini Duyana Kadar Devam Edecektir Excel Açıldıktan Sonra Hücrelere Tıklarsanız Eksik veya Hatalı Aktarabilir. Bilgisayarınızın Sesi Açık Olduğundan Emin Olunuz.", vbDefaultButton1, "UYARI!!!"





Set Excl = New Excel.Application

With Excl



       .Application.visible = True

       .UserControl = True



End With

        Set KTP1 = Excl.Workbooks.Open(CurrentProject.Path & "\PROGRAM DOSYALARI\EXCEL\toplunbt.xlsx")

            SyfAdi = "ÖğrNöbetLis" & Me.DtDonem

            SyfAdiTmp = SyfAdi

            SyfNo = 0

            Do While WorksheetExists(SyfAdiTmp, KTP1) = True

            SyfNo = SyfNo + 1

            SyfAdiTmp = SyfAdi & IIf(SyfNo = 0, "", "(" & SyfNo & ")")

            Loop

            Excl.Sheets.Add.Name = SyfAdiTmp

'###########################################################################################################



Excl.Application.ScreenUpdating = False

Excl.Sheets(SyfAdiTmp).PageSetup.Orientation = xlLandscape

Excl.Sheets(SyfAdiTmp).PageSetup.LeftMargin = "18" 'sol sayfa genişliği

Excl.Sheets(SyfAdiTmp).PageSetup.RightMargin = "15" 'sağ sayfa genişliği

Excl.Sheets(SyfAdiTmp).PageSetup.TopMargin = "15" 'üst sayfa genişliği

Excl.Sheets(SyfAdiTmp).PageSetup.BottomMargin = "15" 'alt sayfa genişliği

Excl.Sheets(SyfAdiTmp).PageSetup.HeaderMargin = "18" 'üst bilgi genişliği

Excl.Sheets(SyfAdiTmp).PageSetup.FooterMargin = "18" 'alt bilgi genişliği

Excl.Sheets(SyfAdiTmp).PageSetup.Zoom = 59



'########################################################################################################

Set SYF = Excl.Sheets(SyfAdiTmp)

With SYF

Excl.Range("A1:AI1").MergeCells = True 'Hücreler Birleştiriliyor

.Range("A2:AI2").MergeCells = True 'Hücreler Birleştiriliyor

.Range("A3:AI3").MergeCells = True 'Hücreler Birleştiriliyor

.Range("A4:AI4").MergeCells = True 'Hücreler Birleştiriliyor

.Range("A1") = Me.txttc

.Range("A2") = txtbaslik1

.Range("A3") = txtbaslik2

.Range("A4") = txtbaslik3

.Range("A6:B6").MergeCells = True

.Range("A6") = "NÖBET DÖNEMİ"

.Range("A6").VerticalAlignment = xlCenter

.Range("A6").HorizontalAlignment = xlCenter

.Range("A7:B7").MergeCells = True

.Range("A7") = Me.DtDonem

.Range("A7").NumberFormat = "dd mmmm yyyy dddd"

.Range("A7").VerticalAlignment = xlCenter

.Range("A7").HorizontalAlignment = xlCenter

.Range("A8") = "SIRA NO"

.Range("A:A").HorizontalAlignment = xlCenter

.Range("A8").VerticalAlignment = xlCenter

.Range("A8").HorizontalAlignment = xlCenter

.Range("B8") = "NÖBETÇİ ÖĞRETMENLER"

.Range("B8").VerticalAlignment = xlCenter

.Range("B8").HorizontalAlignment = xlCenter

.Range("B9:B40").HorizontalAlignment = xlLeft

.Range("C7:AI7").MergeCells = True

.Range("C7") = "NÖBET GÜNLERİ"

.Range("C7").VerticalAlignment = xlCenter

.Range("C7").HorizontalAlignment = xlCenter

.Range("AH8") = "TOPLAM"

.Range("AH8").VerticalAlignment = xlCenter

.Range("AH8").HorizontalAlignment = xlCenter

.Range("AI8") = "İMZA"

.Range("AI8").VerticalAlignment = xlCenter

.Range("AI8").HorizontalAlignment = xlCenter





.Range("C8:AG8").RowHeight = 80

.Range("A1:AL4").Font.Bold = True 'YAZIYI KALIN YAPAR

.Range("A1:AL4").VerticalAlignment = xlCenter 'ortaya hizalaR

.Range("A1:AL4").HorizontalAlignment = xlCenter 'ortaya hizalar

.Range("A1:AL4").RowHeight = 15 'SATIR YÜKSEKLİĞİ AYARLAR

.Range("A6").Font.Bold = True 'YAZIYI KALIN YAPAR

.Range("A7").Font.Bold = True 'YAZIYI KALIN YAPAR

.Range("A8").Font.Bold = True

.Range("B8").Font.Bold = True

.Range("C7").Font.Bold = True

.Range("AH8").Font.Bold = True

.Range("AI8").Font.Bold = True

.Range("A6").Font.size = 12

.Range("A7").Font.size = 12

.Range("A8").Font.size = 12

.Range("B8").Font.size = 12

.Range("C7").Font.size = 12

.Range("AH8").Font.size = 12

.Range("AI8").Font.size = 12

.Range("A6:L8").Borders.LineStyle = xlContinuous

.Range("A:A").ColumnWidth = 7 'SÜTUN GENİŞLİĞİ AYARLA

.Range("B:B").ColumnWidth = 28 'SÜTUN GENİŞLİĞİ AYARLA

.Range("C:AG").ColumnWidth = 4

.Range("AH:AH").ColumnWidth = 10

.Range("AI:AI").ColumnWidth = 15



.Range("C9:AI40").HorizontalAlignment = xlCenter

 On Error Resume Next

.Range("B9").CopyFromRecordset rs2

For i = 9 To rs2.RecordCount + 8

        .Cells(i, "A") = i - 8

Next i

For Each x In .Range("C9:AI" & i)

'       Aralıktaki metni büyük harflere dönüştür.

   x.Value = UCase(x.Value)

Next

With .Range("C8:AG8")

        .VerticalAlignment = xlTop

        .Orientation = -90

End With



'Gün Renk______________________________________hy

Dim GunSay As Byte

Dim Tarih, Trh2 As Long

ADtDonem = Format([Forms]![FrmNobet]![DtDonem], "yyyymm") 'Dönem Formatla

txtdonem = DateSerial(Left(ADtDonem, 4), Mid(ADtDonem, 5), 1) 'Tarih

Tarih = CLng(DateSerial(Year(txtdonem), Month(txtdonem), 1))

Trh2 = CLng(DateSerial(Year(txtdonem), Month(txtdonem) + 1, -1))



GunSay = Day(Trh2) 'seçilen aydaki gün sayısı -1

For x = 0 To GunSay

    t = (Tarih + x) Mod 7

    .Cells(8, x + 3).Value = "   " & Format(Tarih + x, "dd dddd")

    If t > 5 Or t < 2 Then .Range(Cells(8, x + 3), Cells(i, x + 3)).Interior.ColorIndex = 15

Next x

'Gün Renk______________________________________hy



rs2.Close

DoCmd.RunMacro "Makro2" 'işlem bitince BİOS sesi Uyarı BİP

End With

Excl.Application.ScreenUpdating = True



Excl.visible = True

Set Excl = Nothing

DoCmd.SetWarnings True

End Sub