AccessTr.neT

Bul · 26/11/2021, 23:04

Eklediğim programda
frmnobet formunda oluşan takvimi excele gönderirken günleri aya göre tabloya aktararak cuma, cumartesi, pazar sütunlarını ecelde nasıl renglendiririz.

Bul · 27/11/2021, 13:05

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

Bul · 27/11/2021, 16:10

Kodu ilk yüklediğimde çalıştı. Lakin sonrasında form açılışında hata verdi ve kod gerekli renklendirmeyi yapmadı.
https://www.resimupload.org/r/Zf8V3

Bul · 27/11/2021, 17:26

renklendirme yapmadığı olmuştu ama bu hatayı hiç vermedi.
forma yüklediğiniz çalışmada mı bu hatayı verdi, başka bir yerde mi?

Bul · 27/11/2021, 17:55

Kodları butona aktarım. Açılışta hata veriyor. Baktım olay yordamı da yok. Renklendirmeyide yapmıyor. Birde excelde işlem uzun sürüyor. Acaba Access raporunumu kullansam

Bul · 27/11/2021, 18:03

aşağıdaki kodu deneyin isterseniz

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.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

i = i - 1

'Gün Renk______________________________________hy

''''''''''''''''c8

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

With .Range("C8:AG8")

        .VerticalAlignment = xlTop

        .Orientation = -90

        .Borders.LineStyle = xlContinuous

End With



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

(27/11/2021, 17:55)SeferŞANLI yazdı: Acaba Access raporunumu kullansam

excele aktarma amacınızı bilmediğimden bir öneride bulunamam.

AccessTr.neT

Excele Gönderilen Takvimin Hafta Sonu Kısımlarını Renkli Yapmak

Excele Gönderilen Takvimin Hafta Sonu Kısımlarını Renkli Yapmak

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Giriş yap

Hesap oluştur

Konu Linkleri