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 = False

       .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.Application.ScreenUpdating = False

Set SYF = KTP1.Sheets("SablonSyf")

SyfSay = KTP1.Worksheets.Count

SYF.Copy After:=KTP1.Sheets(SyfSay)

KTP1.Sheets(SyfSay + 1).Name = SyfAdiTmp

Set SYF = KTP1.Sheets(SyfAdiTmp)

With SYF



.Range("A1") = Me.txttc

.Range("A2") = txtbaslik1

.Range("A3") = txtbaslik2

.Range("A4") = txtbaslik3

.Range("A7") = Me.DtDonem

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

' On Error Resume Next

.Range("B12") = Dlookup ("mdryrd", "TblSabitler")

.Range("AA17") = Date

.Range("AA18") = Dlookup ("mdr", "TblSabitler")

rs2.MoveLast

rs2.MoveFirst



For RwEk = 1 To rs2.RecordCount - 2

    .Range("10:10").Insert

Next RwEk



'.Range("10:" & rs2.RecordCount + 10).Insert

.Range("B9").CopyFromRecordset rs2



For i = 9 To rs2.RecordCount + 8

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

Next i

i = i - 1

'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



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

   x.Value = UCase(x.Value) '       Aralıktaki metni büyük harflere dönüştür.

Next



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