Çözüldü 40 Haftalık Okul Takviminin Geçen ve Kalan Kısmı

[mdagistanli]

Merhabalar.
40 haftalık okul takviminin 24.haftasındayız. Geçen ve kalan zamanın büyüklüğünü gösteren bir grafik yapmanın veya formülle hücre işaretlemenin yolu var mıdır?
Ekteki okul takvimi dosyasında örnek olarak hafta hücrelerini boyadım. altındaki boş tablo fonksiyonla boyanabilir mi? Okul Takvimi sayfası kaynak olabilir.

Ayrıca dosya upload edildi: https://s2.dosya.tc/server28/8w1db3/Okul_Takvimi.xlsx.html

 

[excelokyanus500]

Fikir vermesi açısından dosyanız ektedir. Her açılışta eğer makrolar etkin ise program çalışır.
Etkin değilse işlem olmayacaktır.

Okul_Takvimi

Kullanılan formülleride dosya silinmesine karşı ekleyelim.

Private Sub Workbook_Open()
Call Son
End Sub
*************************

Function ConcatenateIf(CriteriaRange As Range, Condition As Variant, ConcatenateRange As Range, Optional Separator As String = ",") As Variant

Dim xResult As String
On Error Resume Next
If CriteriaRange.Count <> ConcatenateRange.Count Then
    ConcatenateIf = CVErr(xlErrRef)
    Exit Function
End If
For i = 1 To CriteriaRange.Count
    If CriteriaRange.Cells(i).Value = Condition Then
        xResult = xResult & Separator & ConcatenateRange.Cells(i).Value
    End If
Next i
If xResult <> "" Then
    xResult = VBA.Mid(xResult, VBA.Len(Separator) + 1)
End If
ConcatenateIf = xResult
Exit Function
End Function

Sub Son()
    Dim c, k As Range

    Worksheets(1).Select
    With Worksheets(1).Range("O2:O41")
    Date_Value = Application.Text(Range("p2").Value, "d.mm.yyyy")
        Set c = .Find(what:=Date_Value, LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then

        bul = c.Offset(0, -1)
   
        End If
    End With
    Worksheets(2).Select
    With Worksheets(2).Cells
        Set k = .Find(what:=bul, LookIn:=xlValues, LookAt:=xlWhole)
        If Not k Is Nothing Then
        k.Activate
        With ActiveCell.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = RGB(173, 255, 47)
        .TintAndShade = 0
        .PatternTintAndShade = 0
         End With
        End If
    End With
   
    For Each cell In Worksheets(2).Range("A2:M10")
    If cell <> "" And cell.Value < bul Then
    cell.Interior.Color = RGB(152, 251, 152)
    End If
    Next
   
End Sub

 

[alicimri]

Koşullu biçimlendirme ile yapabilirsiniz.
Açık yeşil olan ilk düzey için

=A7<(BUGÜN()-"11.09.2023")/7

Koyu yeşil olan ikinci düzey için

=A7=YUKARIYUVARLA((BUGÜN()-"11.09.2023")/7;0)

Örnek dosya

Okul_Takvimi.xlsx dosyasını indir - download

Okul_Takvimi.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[mdagistanli]

Fikir vermesi açısından dosyanız ektedir. Her açılışta eğer makrolar etkin ise program çalışır.
Etkin değilse işlem olmayacaktır.
Okul_Takvimi
Kullanılan formülleride dosya silinmesine karşı ekleyelim.

Teşekkür ederim. Alttaki tabloyu silip VB kodlarını uyarlamaya çalışacağım.

Şöyle bir görüntüyle açılıyor;

 

[mdagistanli]

Koşullu biçimlendirme ile yapabilirsiniz.
Açık yeşil olan ilk düzey için

=A7<(BUGÜN()-"11.09.2023")/7

Koyu yeşil olan ikinci düzey için

=A7=YUKARIYUVARLA((BUGÜN()-"11.09.2023")/7;0)

Örnek dosya

Okul_Takvimi.xlsx dosyasını indir - download

Okul_Takvimi.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

Dosyayı indirip çalıştırdım, olmuş teşekkür ederim.
82 satır biçimleme kuralı var. Tek tek oluşturdunuz mu?

 

[alicimri]

Kodları aşağıdaki gibi değiştirin, kopyala özel yapıştır biçimlendirme ile topluca yayın.

=DOLAYLI(ADRES(SATIR();SÜTUN()))<(BUGÜN()-"11.09.2023")/7

=DOLAYLI(ADRES(SATIR();SÜTUN()))=YUKARIYUVARLA((BUGÜN()-"11.09.2023")/7;0)