Koşullu biçimlendirme

[orcunkurtar]

dosya linki

Merhabalar

Ekteki dosyada P2 personel listesi ,E2 Eğitim listesi,E4 Eğitim data ;E5 Eğitim sorgulama sayfası

E5 sayfasında b2 sutununa ID Yazıp Bul dediğimiz zaman aldığı eğitimler listeleniyor.

Karşılaştır batığımız zaman Personelin birimine göre alması gereken eğitimler geliyor ve koşullu biçimlendirme ile karşılaştırma yapılıyor. Ancak Birime göre alınması gereken eğitimler farklı sayıda olduğu için alınan ve alınmayan eğitim sayıları belirli bir alan tarayınca doğru çıkmıyor.

Benim istediğim Karşılaştır butonuna bastığımızda Alması gereken eğitimlerde son satır bularak koşullu biçimlendirme yapması ve kırmızı ve yeşil hucre sayılarını sayıp eğitim oranının belirlenmesi konu hakkında yardımcı olabilir misiniz .

 

[orcunkurtar]

biraz karışık anlattım ama umarım anlaşılmıştır .

 

[orcunkurtar]

Merhabalar

Yardımcı olabilecek var mı

 

[YUSUF44]

Dosyanızda E5 sayfasında H sütunundaki koşullu biçimlendirmeleri iptal edin ve Karıştır düğmesi için aşağıdaki kodları deneyin:

Private Sub CommandButton4_Click()
eski = WorksheetFunction.Max(2, Cells(Rows.Count, "H").End(3).Row)
Range("H2:H" & eski).ClearContents
Range("H2:H" & eski).Interior.Color = xlNone

birim = Range("B8")
sonsatir = Sheets("E4").Cells(Rows.Count, "AA").End(xlUp).Row

Application.ScreenUpdating = False
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
    
    sorgu = "select F2 from[E4$AA1:AB" & sonsatir & "] where F1 ='" & birim & "'"
    Set rs = con.Execute(sorgu)
    [H2].CopyFromRecordset rs
    
    sonH = WorksheetFunction.Max(2, Cells(Rows.Count, "H").End(3).Row)
    sonE = WorksheetFunction.Max(2, Cells(Rows.Count, "E").End(3).Row)
    
    For i = 2 To sonH
        If WorksheetFunction.CountIf(Range("E2:E" & sonE), Cells(i, "H")) > 0 Then
            Cells(i, "H").Interior.Color = vbGreen
        Else
            Cells(i, "H").Interior.Color = vbRed
        End If
    Next
    
    [H:H].EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

 

[orcunkurtar]

Çok teşekkur ederim E5 Sayfasında K2 VE L2 Hucrelerine krmızı ve yesil hucre sayısını yazdrabilir miyiz ?

 

[YUSUF44]

Düğme kodlarını aşağıdakiyle değiştirip deneyin:

Private Sub CommandButton4_Click()
eski = WorksheetFunction.Max(2, Cells(Rows.Count, "H").End(3).Row)
Range("H2:H" & eski).ClearContents
Range("H2:H" & eski).Interior.Color = xlNone
[K2:L2].ClearContents

birim = Range("B8")
sonsatir = Sheets("E4").Cells(Rows.Count, "AA").End(xlUp).Row

Application.ScreenUpdating = False
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
    
    sorgu = "select F2 from[E4$AA1:AB" & sonsatir & "] where F1 ='" & birim & "'"
    Set rs = con.Execute(sorgu)
    [H2].CopyFromRecordset rs
    
    sonH = WorksheetFunction.Max(2, Cells(Rows.Count, "H").End(3).Row)
    sonE = WorksheetFunction.Max(2, Cells(Rows.Count, "E").End(3).Row)
    
    For i = 2 To sonH
        If WorksheetFunction.CountIf(Range("E2:E" & sonE), Cells(i, "H")) > 0 Then
            Cells(i, "H").Interior.Color = vbGreen
            [K2] = [K2] + 1
        Else
            Cells(i, "H").Interior.Color = vbRed
            [L2] = [L2] + 1
        End If
    Next
    
    [H:H].EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

 

[orcunkurtar]

Elinize sağlık çok teşekkür ederim