Koşullu satır renklendirme

[redne]

Herkese slm,
Tur ve rehber takip çizelgesi yapmak istiyorum. Sorum aşağıda ek olarak göndermiş olduğum deneme.xls dosyasının içerisinde bulunmaktadır. Acaba bunu makro ile yapmam mümkün mü?
İlginiz için şimdiden teşekkür ederim.

Redne

 

[danersin]

Ekli dosyayı bir inceleyin.

Neticeyi bildirirseniz sevinirim.

 

[redne]

sayın danersin,
Hiç kuşkusuz tam istediğim gibi yapmışsınız ellerinize sağlık. :dua:
fakat çok küçük bir sorun var 1 gün fazla renklendiriyor. Yani ilk secili alan dahil 7,10 veya 14 gün olması gerekiyordu.Ayrıca yazmayı unutmuşum İstanbul rehberleri kısmında con ve mag turlarının her ikisi değişken olarak 3 ve 4 günlük oluyorlar bu düzeltmemede yardımcı olursanız sevinirim.
Çok teşekkür ederim.
Redne

 

[danersin]

Sub dene()
Dim renk(14)
For i = 1 To 14
renk(i) = Cells(i, 1).Interior.ColorIndex
Next i
c = ActiveCell.Interior.ColorIndex
For j = 1 To 14
    If c = renk(j) Then
        For k = ActiveCell.Column + 1 To ActiveCell.Column + Cells(j, 2) - 1
            If Cells(ActiveCell.Row, k).Interior.ColorIndex > 1 Then
            xxx = MsgBox("yolumda boya var")
            Exit Sub
            End If
            Next k
    Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column + Cells(j, 2) - 1)).Interior.ColorIndex = renk(j)
    End If
Next j
End Sub

Sorunun ilk bölümü için kodu yukarıdaki ile değiştirirseniz hallolur.

Ama 2. sorun o kadar basit değil.. bilgisayara ya 3 ya 4 yap diyemeyeceğimiz için.. belki onuda kodda aşağıdaki gibi birşey yapıp çözebiliriz. pek pratiklik sağlamıyor ama 39. satırdan aşağıda ctrl+q ye bastığınızda kaç gün diye ve renk kodunu(bir rakam) size soruyor. CON ve MAG için renk kodu tespitini size bırakıyorum.

Sub dene()
Dim renk(14)

If ActiveCell.Row > 39 Then
kac = InputBox("kaç hücre boyansın")
ren = InputBox("renk kodu")
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column + kac - 1)).Interior.ColorIndex = ren
Exit Sub
End If


For i = 1 To 14
renk(i) = Cells(i, 1).Interior.ColorIndex
Next i
c = ActiveCell.Interior.ColorIndex
For j = 1 To 14
    If c = renk(j) Then
        For k = ActiveCell.Column + 1 To ActiveCell.Column + Cells(j, 2) - 1
            If Cells(ActiveCell.Row, k).Interior.ColorIndex > 1 Then
            xxx = MsgBox("yolumda boya var")
            Exit Sub
            End If
            Next k
    Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column + Cells(j, 2) - 1)).Interior.ColorIndex = renk(j)
    End If
Next j
End Sub

 

[redne]

sayın danersin,
Bundan iyisi can sağlığı,
yardımlarınız için çok teşekkür ederim

Redne :hey: