Mesai Saati Ayarlama

[m.ensar]

Hocalarım Ek liste içerisine de açıklamasını yazdım. Pazartesi Salı Çarşamba izinli perşembe cuma 8/17:00 cumartesi pazar 19:30/07:30 arası çalışma saatlerini ay değiştikçe otomatik gelmesini istiyorum. Yardım eder misiniz? Ekte daha ayrıntılı anlattım.

 

[Ali]

Aşağıdaki kodu dener misiniz.

Sub CalismaCizelgesiGuncelle()
    Dim ws As Worksheet
    Dim veriWs As Worksheet
    Dim i As Long
    Dim tarih As Date
    Dim gunAdi As String
    Dim resmiTatil As Boolean
    Dim sonSatir As Long
    Dim tatilSatir As Long
    Dim tatilTarihi As Date

    Set ws = ThisWorkbook.Sheets("TAKİP formu") ' Takip formu sayfası
    Set veriWs = ThisWorkbook.Sheets("Veri") ' Resmi tatillerin olduğu sayfa

    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ' Tarihlerin olduğu sütun B

    For i = 2 To sonSatir ' Başlık satırını atla
        If IsDate(ws.Cells(i, "B").Value) Then
            tarih = ws.Cells(i, "B").Value
            gunAdi = Format(tarih, "dddd", vbUseSystemDayOfWeek)
            resmiTatil = False

            ' Resmi tatil kontrolü (Veri sayfasında A sütunu)
            For tatilSatir = 2 To veriWs.Cells(veriWs.Rows.Count, "A").End(xlUp).Row
                If IsDate(veriWs.Cells(tatilSatir, "A").Value) Then
                    tatilTarihi = veriWs.Cells(tatilSatir, "A").Value
                    If DateValue(tarih) = DateValue(tatilTarihi) Then
                        resmiTatil = True
                        Exit For
                    End If
                End If
            Next tatilSatir

            If resmiTatil Then
                ws.Cells(i, "D").Value = "RESMİ TATİL"
            Else
                Select Case gunAdi
                    Case "Pazartesi", "Salı", "Çarşamba"
                        ws.Cells(i, "D").Value = "İZİNLİ"
                    Case "Perşembe", "Cuma", "Cumartesi", "Pazar"
                        ws.Cells(i, "D").Value = "08:00 - 17:00"
                End Select
            End If
        End If
    Next i

    MsgBox "Çalışma çizelgesi güncellendi.", vbInformation
End Sub

 

[m.ensar]

Sub RenkleriKopyala()
Dim ws As Worksheet
Dim i As Long
Dim kaynakHücre As Range
Dim hedefAralik As Range

Set ws = ThisWorkbook.Sheets("TAKİP FORMU")
For i = 6 To 36
Set kaynakHücre = ws.Range("B" & i)
Set hedefAralik = ws.Range("C" & i & "" & i)

If Not IsEmpty(kaynakHücre) Then
hedefAralik.Interior.Color = kaynakHücre.Interior.Color
End If
Next i
Call KosulluBicimlendirmeRenkleriKopyala
MsgBox "Renkler başarıyla kopyalandı!"
End Sub
Sub KosulluBicimlendirmeRenkleriKopyala()
Dim ws As Worksheet
Dim i As Long
Dim kaynakHücre As Range
Dim hedefAralik As Range

Set ws = ThisWorkbook.Sheets("TAKİP FORMU")

For i = 6 To 36
Set kaynakHücre = ws.Range("B" & i)
Set hedefAralik = ws.Range("C" & i & "" & i)

If Not IsEmpty(kaynakHücre) Then
hedefAralik.Interior.Color = kaynakHücre.DisplayFormat.Interior.Color
End If
Next i

End Sub


Ali hocam çok teşekkür ediyorum. Yazdığınız kodda RENKLERİ kopyalama komutu yok ben de sizin kodların altına ek çalışmadaki kodları ekledim yeni bir buton koydum renkleri de o şekil çekiyorum. çok teşekkür ederim

 

[Ali]

Sayfanızdaki koşullu biçimlendirmeyi silin yeni kodu deneyin. Renkleri de ekledim.

Sub CalismaCizelgesiGuncelle()
    Dim ws As Worksheet
    Dim veriWs As Worksheet
    Dim i As Long
    Dim tarih As Date
    Dim gunAdi As String
    Dim resmiTatil As Boolean
    Dim sonSatir As Long
    Dim tatilSatir As Long
    Dim tatilTarihi As Date

    Set ws = ThisWorkbook.Sheets("TAKİP formu") ' Takip formu sayfası
    Set veriWs = ThisWorkbook.Sheets("Veri") ' Resmi tatillerin olduğu sayfa

    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ' Tarihlerin olduğu sütun B

    For i = 2 To sonSatir ' Başlık satırını atla
        If IsDate(ws.Cells(i, "B").Value) Then
            tarih = ws.Cells(i, "B").Value
            gunAdi = Format(tarih, "dddd", vbUseSystemDayOfWeek)
            resmiTatil = False

            ' Resmi tatil kontrolü
            For tatilSatir = 2 To veriWs.Cells(veriWs.Rows.Count, "A").End(xlUp).Row
                If IsDate(veriWs.Cells(tatilSatir, "A").Value) Then
                    tatilTarihi = veriWs.Cells(tatilSatir, "A").Value
                    If DateValue(tarih) = DateValue(tatilTarihi) Then
                        resmiTatil = True
                        Exit For
                    End If
                End If
            Next tatilSatir

            ' Arka plan ve değer atama
            With ws.Range("B" & i & ":D" & i)
                .Interior.ColorIndex = xlNone ' Önce arka planı temizle
            End With

            If resmiTatil Then
                ws.Cells(i, "D").Value = "RESMİ TATİL"
                ws.Range("B" & i & ":D" & i).Interior.Color = RGB(255, 230, 153) ' Açık turuncu
            Else
                Select Case gunAdi
                    Case "Pazartesi", "Salı", "Çarşamba"
                        ws.Cells(i, "D").Value = "İZİNLİ"
                    Case "Perşembe", "Cuma", "Cumartesi", "Pazar"
                        ws.Cells(i, "D").Value = "08:00 - 17:00"
                End Select

                If gunAdi = "Cumartesi" Or gunAdi = "Pazar" Then
                    ws.Range("B" & i & ":D" & i).Interior.Color = RGB(198, 239, 206) ' Yeşil
                End If
            End If
        End If
    Next i

    MsgBox "Çalışma çizelgesi güncellendi.", vbInformation
End Sub

 

[m.ensar]

Hocam çok teşekkür ederim harika olmuş emeğinize sağlık