AccessTr.neT - Excele Gönderilen Takvimin Hafta Sonu Kısımlarını Renkli Yapmak

Sayfalar: 1 2 3 4 5

Hocam diyelim 10 öğretmen ekledim. nöbetlerini yazdım. ve excele gönderdim. Böyle birşeyle karşılaşıyorum.
https://www.resimupload.org/r/Zfuyr

https://www.resimupload.org/r/ZOVWc

olması gereken şey. Seçilen tarihteki personele göre sarı alanların silinerek o tarihteki görevlilere göre yeniden şekillendirilmesi ve altına kırmızı ile göstwrilen yere onayların açılması.

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

Hazırlamış olduğum örneği incelermisiniz Sayın @berduş hocam ve @SeferŞANLI

bence hata yok sayın @lemoncher2 düzgün çalışıyor elinize sağlık

@berduş Sağolun Hocam Kolay Gelsin.

Evet elinize emeğinize, ayırdığınız kıymetli zamanıza çok teşekkür ederim. Konu çözüme kavuşmuştur. Taşıyabilirsiniz sayın Hocalarım.

Sayfalar: 1 2 3 4 5