Hücre renklendirme

[sadi_52]

Arkadaşlar forma üye olalı yaklaşık 4 ay oldu çok güzel çalışmalar var yaptığım aramalar sonunda bulbuğum dosyaya birkaç ilave yapmak istedim ama başaramadım excel bilgim çok zayıf olsada excel harika bir program olduğu için bu programda çalışmayı tercih ediyorum yapmak istediğim şeyi detaylı olarak ekteki dosyada anlattım yardımcı olursanız sevinirim

 

[Ömer]

Merhaba,

Ölçütünüz fazla ise, data sayfasında ölçütlerin tanımlayıp aramayı buradan yapmanızı tavsiye ederim.

Eki inceleyin, data sayfasında değerler renkleri belirlenerek yazılmıştır. Veri sayfası A sütuna değer girerek sonuçları gözlemleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Sd As Worksheet, deg
 
    Set Sd = Sheets("data")
 
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Selection.Cells.Count > 1 Then Exit Sub
 
    deg = UCase(Replace(Replace(Target, "ı", "I"), "i", "İ"))
    Target.Interior.ColorIndex = xlNone
 
    Application.EnableEvents = False
 
    Set c = Sd.[A:A].Find(deg, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        [COLOR=blue]Sd.Cells(c.Row, "A").Copy Target[/COLOR]
        Target.Offset(0, 1) = WorksheetFunction.CountIf( _
                            Range("A1:A" & Target.Row), Target)
    Else
        MsgBox deg & "değerini bulamadım"
    End If
 
    Application.EnableEvents = True
 
End Sub

.

 

[sadi_52]

Sayın ömer öncelikle cevabınız için teşekkür ederim işime yaradı ama b sütünundaki değerlerde aynı rengi alabilirmi acaba böyle olursa daha iyi olacak teşekkürler

 

[Ömer]

#2 numaralı mesajda mavi işaretlediğim bölgeyi aşağıdaki satırla değiştiriniz.

Sd.Cells(c.Row, "A").Copy Range("A" & Target.Row, "B" & Target.Row)

.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim deg As String, adres As String
    
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    
    On Error Resume Next
    deg = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
    adres = "A" & Target.Row & ":B" & Target.Row
    Range(adres).Interior.ColorIndex = xlNone
    Target.Interior.ColorIndex = xlNone
    Target.Offset(0, 1).ClearContents
    
    If deg = "B" Then
        Range(adres).Interior.Color = vbBlue
        Target.Offset(0, 1) = WorksheetFunction.CountIf(Range("A1:A" & Target.Row), Target)
    ElseIf deg = "İ" Then
        Range(adres).Interior.Color = vbRed
        Target.Offset(0, 1) = WorksheetFunction.CountIf(Range("A1:A" & Target.Row), Target)
    ElseIf deg = "S" Then
        Range(adres).Interior.Color = vbYellow
        Target.Offset(0, 1) = WorksheetFunction.CountIf(Range("A1:A" & Target.Row), Target)
    ElseIf deg = "K" Then
        Range(adres).Interior.ColorIndex = 53
        Target.Offset(0, 1) = WorksheetFunction.CountIf(Range("A1:A" & Target.Row), Target)
    ElseIf deg = "C" Then
        Range(adres).Interior.ColorIndex = 10
        Target.Offset(0, 1) = WorksheetFunction.CountIf(Range("A1:A" & Target.Row), Target)
    ElseIf deg = "L" Then
        Range(adres).Interior.ColorIndex = 20
        Target.Offset(0, 1) = WorksheetFunction.CountIf(Range("A1:A" & Target.Row), Target)
    End If
End Sub

 

[sadi_52]

Sayın korhan ayhan ve sayım ömer çok teşekkür ederim iki kodda işime yaradı bir ricam daha olucak b sütünundaki değerleri yıl sonunda sıfırlanıp yeni yılda tekrar 1 den başlamasını istiyorum böyle bişey yapılabilirmi acaba

 

[Korhan Ayhan]

Selamlar,

Yıl sonunda A-B sütunlarını silerseniz değerler yeniden 1 den başlayacaktır.

 

[sadi_52]

Korhan bey simeden olmazmı çünkü silersek veriler kabolur c,d,e,f ve g sütunlarında verilerimde var onlarda zarar görmezmi

 

[Korhan Ayhan]

Selamlar,

Silmedende belki olabilir. Ama sıfırlamaktan kastınız nedir. Örnek dosyanız üzerinde detalı olarak açıklar mısınız?

 

[sadi_52]

sayın korhan ayhan dosyam ektedir detaylı anlatmaya çalıştım umarım faydalı olur

 

[Korhan Ayhan]

Selamlar,

Örnek dosyanızda birde tarih sütunu kullanmışsınız. Bu sütunda formül içine dahil edilip yıl kontrolü yapılabilir.

Aşağıdaki kodu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim deg As String, adres As String, formul As String
    Dim formul_adres_1 As String, formul_adres_2 As String
    
    If Intersect(Target, Range("E:E")) Is Nothing Then Exit Sub
    
    On Error Resume Next
    deg = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
    adres = "E" & Target.Row & ":F" & Target.Row
    Range(adres).Interior.ColorIndex = xlNone
    Target.Interior.ColorIndex = xlNone
    Target.Offset(0, 1).ClearContents
    
    formul_adres_1 = "D2:D" & Target.Row
    formul_adres_2 = "E2:E" & Target.Row
    formul = "=SUMPRODUCT((YEAR(" & formul_adres_1 & ")=YEAR(" & "D" & Target.Row & "))*(" & formul_adres_2 & "=" & Target.Address & "))"
    
    If deg = "B" Then
        Range(adres).Interior.Color = vbBlue
        Target.Offset(0, 1) = Evaluate(formul)
    ElseIf deg = "İ" Then
        Range(adres).Interior.Color = vbRed
        Target.Offset(0, 1) = Evaluate(formul)
    ElseIf deg = "S" Then
        Range(adres).Interior.Color = vbYellow
        Target.Offset(0, 1) = Evaluate(formul)
    ElseIf deg = "K" Then
        Range(adres).Interior.ColorIndex = 53
        Target.Offset(0, 1) = Evaluate(formul)
    ElseIf deg = "C" Then
        Range(adres).Interior.ColorIndex = 10
        Target.Offset(0, 1) = Evaluate(formul)
    ElseIf deg = "L" Then
        Range(adres).Interior.ColorIndex = 20
        Target.Offset(0, 1) = Evaluate(formul)
    End If
End Sub

 

[pylor]

sayın korhan bey vermiş olduğunuz cevaplardan dolayı size çok teşekkür ederim gönderdiğiniz kodlar tam istediğim gibi oldu elinize sağlık korhan hocam kusuruma bakmazsanız bir sorum daha olucak mesala sayfa 1 de a1 hücresinin rengi kırmızı ise sayfa 2 de a1 hücresine a yazzın sarı ise b yazzın bu işlemi excelde biçim menüsünden koşullu biçimlendirme ile yapabilirmiyim yoksa özel bir kod yada formülmü kullanmak gerek

 

[sadi_52]

sayın pilor aslında bu konu başlığı bana ait olmasına rağmen korhan beyin göndermiş olduğu kodları nasıl kullanıcamı bulamadım rica etsem yardımcı olurmusunuz

 

[pylor]

sayın sadi 52 bende formda yeni sayılırım pek bir bilgim yok aslında korhan beyin göndermiş olduğu kodların yaptığı işe benzer bir şeye ihtiyacım vardı kodlar üstünde biraz oynama yapıp kendime uyarladım nasıl yaptığımı size anlatayım umarım yardımcı olabilirim kodları kopyalayıp excelde kullanmak istediğiniz sayfayı acın ve kodları sayfanın kod bölümüne yapıştırın hangi sütunları renklendirmek istiyorsanız kod üstünde bulunan sütün isimlerini değiştirin sonrasında kod sayfasını kapatın ve excel sayfasında istediğiniz sütunlara verilerinizi girip sonucu görebilirsiniz ben böyle yaptım umarım size faydası olur

 

[Korhan Ayhan]

Selamlar,

Eklediğiniz örnek dosyda "D" sütununa tarih girin. "E" sütununuda verinizi girin. İstediğiniz işlem gerçekleşecektir.

sayın pilor aslında bu konu başlığı bana ait olmasına rağmen korhan beyin göndermiş olduğu kodları nasıl kullanıcamı bulamadım rica etsem yardımcı olurmusunuz

 

[sadi_52]

sayın korhan teşekkür ederim olayı çözdüm