• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Girdiğim Değer Kadar Hücreyi Renklendirme

A

AyYıldızım

Katılım
15 Nisan 2008
Mesajlar
303
Excel Vers. ve Dili
2010
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.
 
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.
 
Aşağıdaki kodları ilgili sayfanın kod bölümüne yapıştırıp deneyiniz:
Kod: 
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
 
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.
 
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:

Kod: 
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
 
Son düzenleme:
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.
 
Alternatif;

Kod: 
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
 
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ı...

Kod: 
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
 
AyYıldızım' Alıntı:
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.
Genişletmek için tıkla ...

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

Kod: 
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
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst