Hücredeki kayıtlara göre listele

[omeryılmaz]

Değerli Hocalarım, Öncelikler saygılarımı sunuyorum...

Listele dediğimde, listede mevcut kurumları saymaktadır. Buna ek olarak UYGUN , UYGUN DEĞİL yazan hücreleri D hücresinde kayıtlı ilgili kuruma göre Kimyasal,Tam Kimyasal sonuç olarak listelemek istiyorum.

Dosyada ayrıntılı açıklama mevcuttur...

İlgilenirseniz sevinirim. Saygılar............

 

[Orion1]

Ömer bey ;
Dosyanız ekte.
İyi çalışmalar.

 

[Korhan Ayhan]

Selamlar,

Aslında bu işlemi ÖZET TABLO ile yaparsanız daha esnek olacaktır. Denemenizi öneririm. Makro ile ilgili olarak aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub LİSTELE()
    Dim X As Long, BUL As Range, ADRES As String
 
    With Sheets("K.TOPLU")
    .Range("AK2:AO" & .Range("D65536").End(3).Row).ClearContents
    .Columns("AJ:AJ").ClearContents
    .Columns("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AJ1"), Unique:=True
    .Range("AJ2:AJ65536").Sort Key1:=.Range("AJ2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
    For X = 2 To .Range("AJ65536").End(3).Row
        .Cells(X, "AK") = WorksheetFunction.CountIf(.Range("D:D"), .Cells(X, "AJ"))
            Set BUL = .Range("D:D").Find(.Cells(X, "AJ"), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                If .Cells(BUL.Row, "AF") = "Kimyasal" And .Cells(BUL.Row, "AG") = "UYGUN" Then
                .Cells(X, "AL") = .Cells(X, "AL") + 1
                ElseIf .Cells(BUL.Row, "AF") = "Kimyasal" And .Cells(BUL.Row, "AG") = "UYGUN DEĞİL" Then
                .Cells(X, "AM") = .Cells(X, "AM") + 1
                ElseIf .Cells(BUL.Row, "AF") = "Tam Kimyasal" And .Cells(BUL.Row, "AG") = "UYGUN" Then
                .Cells(X, "AN") = .Cells(X, "AN") + 1
                ElseIf .Cells(BUL.Row, "AF") = "Tam Kimyasal" And .Cells(BUL.Row, "AG") = "UYGUN DEĞİL" Then
                .Cells(X, "AO") = .Cells(X, "AO") + 1
                End If
            Set BUL = .Range("D:D").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
    Next
    End With
    
    MsgBox "İşleminiz tamamlanıştır.", vbInformation
End Sub

 

[omeryılmaz]

Korhan ve Evren hocaya Şükranlarımı sunuyorum.

Elinize sağlık, sağolun.....

 

[Orion1]

Korhan ve Evren hocaya Şükranlarımı sunuyorum.

Elinize sağlık, sağolun.....

Rica ederim.
İyi çalışmalar.