Bana karışık geldi akşam tekrar bakacağım yapabilirsem eklerim belki uzman üstadlarda ilgileniyorlardır.

(12/12/2023, 12:18)feraz yazdı: Bana karışık geldi akşam tekrar bakacağım yapabilirsem eklerim belki uzman üstadlarda ilgileniyorlardır.

ilgi ve emeğiniz için çok teşekkür ederim.

Rica ederim,sanırım çözen çıkmadı benim yaptığım doğru gibi.

---

Ayrıca kütüphaneden işaretli olanı işaretlemelisiniz başka dosyada kullanacaksanız.

Ufak bir hata olmuş çözebilirsem eklerim.

Bunu deneyin.

(13/12/2023, 01:26)feraz yazdı: Rica ederim,sanırım çözen çıkmadı benim yaptığım doğru gibi.

Kod:

Function benzersizFirmalar(ByVal i As Long) As Dictionary
   Dim dic As Dictionary, son As Long, say As Long, ii As Long, key As String
    say = 0
    Set dic = New Dictionary
    With ThisWorkbook.Worksheets("Özet Tablo")
        son = Worksheets(.Cells(i, 1).Value).Range("A" & Rows.Count).End(3).Row
        If son < 2 Then GoTo sonSub
        For ii = 2 To son
            key = ThisWorkbook.Worksheets(.Cells(i, 1).Value).Range("B" & ii).Value
            dic(key) = dic(key) + 1
        Next
    End With
sonSub:
    Set benzersizFirmalar = dic
End Function

Sub getir(ByVal kac As Long, dic As Dictionary, syf As Worksheet) 'ByVal deger As String, ByVal alan As Integer, ByVal i As Integer
Dim bul_ilk As Long, bul_Son As Long, say As Long, key, i As Long, alan As String
Dim sayBitti As Long, sayDevam As Long, sayIptal As Long, deger As String
Dim syfOzet As Worksheet

Set syfOzet = ThisWorkbook.Worksheets("Özet Tablo")

sayBitti = 0
sayDevam = 0
sayIptal = 0

With syf
    For Each key In dic
        
        bul_ilk = .Range("B:B").Find(key, , xlValues, 1, xlRows, xlNext).Row
        bul_Son = .Range("B:B").Find(key, , xlValues, 1, xlRows, xlPrevious).Row
        say = 0
        For i = bul_ilk To bul_Son
            If .Cells(i, "H").Value = "Bitti" Then say = say + 1
            deger = .Cells(i, "H").Value
        Next
        
        If say > 1 And say = dic(key) Then
            sayBitti = sayBitti + 1
        Else
            Select Case deger
                Case "Bitti": alan = "B": sayBitti = sayBitti + 1
                Case "Devam Ediyor": alan = "C": sayDevam = sayDevam + 1
                Case "Ýptal": alan = "D": sayIptal = sayIptal + 1
            End Select
        
            Select Case alan
                Case "B": syfOzet.Cells(kac, alan).Value = sayBitti
                Case "C": syfOzet.Cells(kac, alan).Value = sayDevam
                Case "D": syfOzet.Cells(kac, alan).Value = sayIptal
            End Select
        End If
    Next
End With
Set syfOzet = Nothing
End Sub

Private Sub CommandButton1_Click()
    Dim i As Long
    With ThisWorkbook.Worksheets("Özet Tablo")
        .Range("B2:D" & .Cells(Rows.Count, "A").End(3).Row + 1).ClearContents
        For i = 2 To .Range("A" & Rows.Count).End(3).Row
          .Range("B" & i & ":D" & i).Value = 0
           getir i, benzersizFirmalar(i), ThisWorkbook.Worksheets(.Range("A" & i).Value)
        Next
    End With
End Sub

---

Ayrıca kütüphaneden işaretli olanı işaretlemelisiniz başka dosyada kullanacaksanız.

Emeğinize sağlık;

Kütüphane kısmına nelerden giriyoruz, birde ben kendi anadosyama kodları yapıştırdıktan sonra firmabenzersiz hata veriyor.[img][/img]