Girdiğim Değer Kadar Hücreyi Renklendirme

[AyYıldızım]

Arkadaşlar şöyle birşey yapabilirmiyiz.

Ahmet : 5
Mehmet : 3
Ali : 4

Ahmet Mehmet Ali
satır 1 satır 1 satır 1
satır 2 satır 2 satır 2
satır 3 satır 3 satır 3
satır 4 satır 4 satır 4
satır 5 satır 5 satır 5
. . .
. . .

Kişilerin karşısında yazan değer kadar, alttaki kişiler sutunlarının altındaki hücrelerin renkli olmasını istiyorum(içerisinde bir değer olmayacak sadece renk) mesela yeşil(ahmette 5 satır, mehmette 3 satır alide 4 satır gibi), Ve yukarıda kişilerin karşısına tekrar değer girdiğimde enson renklendirdiği satırdan itibaren devam edecek. nasıl yapabiliriz. Yardımlarınızı bekliyorum. İyi çalışmalar.

 

[YUSUF44]

Bunu örnek dosya olmadan yapmak zor olur. imzamda belirttiğim gibi dosya yapınızla aynı yapıda örnek bir dosya paylaşın lütfen.

 

[AyYıldızım]

Altın üyeliğim sona erdi, şimdilik dosyayı aşağıdaki linkte ekledim yardımcı olursanız sevinirim.

Dosyayı İndir

 

[YUSUF44]

Aşağıdaki kodları ilgili sayfanın kod bölümüne yapıştırıp deneyiniz:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D3:D8]) Is Nothing Then Exit Sub
sıra = WorksheetFunction.Match(Target.Offset(0, -1), [C10:H10], 0)
adet = Target.Value
If Target < 0 Then Exit Sub
If adet > 60 Then
    MsgBox "60'tan fazla hücre yoktur"
    Application.EnableEvents = False
    Target = ""
    Target.Select
    Application.EnableEvents = True
    GoTo 10
End If

If Target = 0 Or Target = "" Then
    Range(Cells(11, sıra + 2), Cells(70, sıra + 2)).Interior.Color = vbRed
ElseIf Target > 0 And Target <= 60 Then
    Range(Cells(11, sıra + 2), Cells(adet + 10, sıra + 2)).Interior.Color = vbGreen
ElseIf adet < 60 Then
    Range(Cells(adet + 11, sıra + 2), Cells(70, sıra + 2)).Interior.Color = vbRed
End If

10:

End Sub

 

[AyYıldızım]

Yusuf Bey gayet güzel olmuş yalnız yeni değer girmek için değer sildiğim de boyanan kısım tekrar kırmızı olmayacak, alta doğru değer kadar boyama işlemi devam edecek. Saygılar.

 

[YUSUF44]

NAsıl yani? Diyelim ki 3 yazıyordu ve 11:13 yeşil oldu, sonra sileceksiniz, sonra 2 yazacaksınız ve 11:15'in mi yeşil olmasını istiyorsunuz?

Eğer öyleyse aşağıdaki kodları kullanmalısınız. Kodlar o sütunda yeşil olmayan ilk hücreden itibaren, girdiğiniz sayı kadar hücreyi yeşile boyar:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D3:D8]) Is Nothing Then Exit Sub
sıra = WorksheetFunction.Match(Target.Offset(0, -1), [C10:H10], 0)
adet = Target.Value
If Target < 0 Then Exit Sub

For i = 11 To Rows.Count
    If Cells(i, sıra + 2).Interior.Color <> vbGreen Then
        Range(Cells(i, sıra + 2), Cells(i + Target - 1, sıra + 2)).Interior.Color = vbGreen
        GoTo 10
    End If
Next
10:

End Sub

 

[AyYıldızım]

Yusuf Bey çok güzel olmuş, tek sıkıntı değeri sildiğim de yada değer girdiğim hücrede her delete bastığımda alta doğru bir satır boyuyor, bunu nasıl engelleriz.

 

[Korhan Ayhan]

Alternatif;

Sub Renklendir()
    Dim Veri As Range, Bul As Range, Satir As Long
    Onay = MsgBox("Bu değerlere göre renklendirmek istiyor musunuz?", vbExclamation + vbYesNo)
    If Onay = vbNo Then Exit Sub
    For Each Veri In Range("D3:D8")
        If Veri.Value > 0 Then
            Set Bul = Rows(10).Find(Veri.Offset(0, -1).Value, , , xlWhole)
            If Not Bul Is Nothing Then
                For X = 70 To 11 Step -1
                    If Cells(X, Bul.Column).Interior.Color = vbGreen Then
                        Satir = X + 1
                        Exit For
                    End If
                Next
                If Satir = 0 Then Satir = 11
                If Satir > 70 Then
                    Range(Cells(70, Bul.Column), Cells(70, Bul.Column)).Interior.Color = vbGreen
                ElseIf (Satir + Veri.Value) > 70 Then
                    Range(Cells(Satir, Bul.Column), Cells(70, Bul.Column)).Interior.Color = vbGreen
                Else
                    Range(Cells(Satir, Bul.Column), Cells(Satir + Veri.Value, Bul.Column)).Interior.Color = vbGreen
                End If
                Satir = 0
            End If
        End If
    Next
End Sub

 

[sakman26]

selam,
bu örnek de benden olsun..
isimlerin satırlarında olmak üzere A ve B kolonlarına Yeşil Kırmızı Renk adetleri yazıldı. Değer girdiğinizde , onay soracak ve onaylarsanız A ve B kolonlarındaki değerler girdiğiniz değere göre değişecek. Bu değerlere göre de Koşullu Biçimlendirme ile renklendirmeler uygulanacak.
Kod sayfanın kod bölümüne uygulandı...

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect([d3:d8], Target) Is Nothing And Target.Count = 1 Then
    Onay = MsgBox("Bu değere göre renklendirmek istiyor musunuz?", vbExclamation + vbYesNo)
    If Onay = vbYes Then
      Target.Offset(0, -2) = Target.Offset(0) + Target.Offset(0, -2)
    End If
End If
Application.EnableEvents = True
End Sub

link : http://s9.dosya.tc/server/0t08b4/Renklendirme.rar.html

 

[YUSUF44]

Yusuf Bey çok güzel olmuş, tek sıkıntı değeri sildiğim de yada değer girdiğim hücrede her delete bastığımda alta doğru bir satır boyuyor, bunu nasıl engelleriz.

Küçük bir değişiklik yaptım:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D3:D8]) Is Nothing Then Exit Sub
sıra = WorksheetFunction.Match(Target.Offset(0, -1), [C10:H10], 0)
adet = Target.Value
If Target <[B][COLOR="Red"]=[/COLOR][/B] 0 Then Exit Sub

For i = 11 To Rows.Count
    If Cells(i, sıra + 2).Interior.Color <> vbGreen Then
        Range(Cells(i, sıra + 2), Cells(i + Target - 1, sıra + 2)).Interior.Color = vbGreen
        GoTo 10
    End If
Next
10:

End Sub

 

[AyYıldızım]

Arkadaşlar harika işler çıkarmışsınız, kusura bakmayın geç dönüş yaptım. Hepinize sonsuz teşekkürler, Allah sizlerden razı olsun. YUSUF44, Korhan Ayhan, sakman26