Şarta bağlı toplam sayı alma

[neseterkutsesli]

Merhaba
B sütünun'da koyu olan tedarikçilerin sayısını formül yada makro yolu ile öğrenebilirmiyim

 

[Muzaffer Ali]

Merhaba.
Bir modüle kopyalayıp çalıştırın.

Sub Test()

    Dim SonSatir As Long
    Dim KoyuSay As Long
    Dim Alan As Range
    SonSatir = Cells(Rows.Count, "B").End(xlUp).Row
    KoyuSay = 0
    For Each Alan In Range("B2:B" & SonSatir)
        If Alan.Value <> "" Then
            If Alan.Font.Bold = True Then
                KoyuSay = KoyuSay + 1
            End If
        End If
    Next Alan
    MsgBox "Koyu hücre sayısı: " & KoyuSay
End Sub

 

[Ali]

Function BoldSay(sutun As Range) As Long
    Dim hucre As Range
    For Each hucre In sutun
        If hucre.Font.Bold = True And hucre.Value <> "" Then
            BoldSay = BoldSay + 1
        End If
    Next hucre
End Function

Sonuç göreceğiniz hücreye

=BoldSay(B2:B500)

yazın.

 

[neseterkutsesli]

teşekkür ederim çok sağolun.

 

[neseterkutsesli]

Muazaffer Hocam,
ek olarak toplam 373 tedarikçi var koyu renk ise 8 satır üzerinde eklemeler olabiliyor yine tüm satırı baz alabiliriz
tıkladığımda 8/373 olarak sonuç almak istiyorum bunu koda yazabilirmiyiz.

 

[Muzaffer Ali]

Muazaffer Hocam,
ek olarak toplam 373 tedarikçi var koyu renk ise 8 satır üzerinde eklemeler olabiliyor yine tüm satırı baz alabiliriz
tıkladığımda 8/373 olarak sonuç almak istiyorum bunu koda yazabilirmiyiz.

Bu açıklamadan bir şey anlamadım.

 

[neseterkutsesli]

B sütununda toplam 373 tedarikçi var kalın dolgu olan 8 tedarikçi var makro kodunu içine 8/373 olacak şekilde kod revize edebilirmiyiz

 

[Muzaffer Ali]

Örnek dosyada 8 değil 16 tane Kalın metin var.
Buna göre 16/373 oluyor.

Aşağıdaki kodu deneyin.

Sub Test()

    Dim SonSatir As Long
    Dim KoyuSay As Long
    Dim Alan As Range
    SonSatir = Cells(Rows.Count, "B").End(xlUp).Row
    KoyuSay = 0
    For Each Alan In Range("B2:B" & SonSatir)
        If Alan.Value <> "" Then
            If Alan.Font.Bold = True Then
                KoyuSay = KoyuSay + 1
            End If
        End If
    Next Alan
    MsgBox "Kalın metin sayısı: " & KoyuSay & vbLf & "Tedarikçi Sayısı: " & (SonSatir - 1) & vbLf & "Bölme sonucu: " & KoyuSay / (SonSatir - 1)
End Sub

 

[Ali]

B sütununda toplam 373 tedarikçi var kalın dolgu olan 8 tedarikçi var makro kodunu içine 8/373 olacak şekilde kod revize edebilirmiyiz

Başkaları da faydalanır sizin pek ilginiz çekmedi sanırım.

Function BoldToplamKesir(rng As Range) As String
    Dim c As Range
    Dim boldN As Long
    Dim totalN As Long

    For Each c In rng
         If Len(Trim(CStr(c.Value))) > 0 Then
            totalN = totalN + 1
          
            If c.Font.Bold = True Then
                boldN = boldN + 1
            End If
        End If
    Next c

    If totalN = 0 Then
        BoldToplamKesir = "0/0"
    Else
        BoldToplamKesir = boldN & "/" & totalN
    End If
End Function

Formül aşağıdaki gibi kullanılır.

=BoldToplamKesir(B2:B500)

 

[neseterkutsesli]

Muzaffer hocam teşekkür ederim,
Ali hocam ilginize emeğinize sağlık verdiğiniz kodu kopyaladım ama çalıştıramadım vba'da biraz acemiyim dosyayı ekleyip gönderebilirseniz memnun olurum iyi çalışmalar dilerim.

 

[Ali]

Dosyaya uygulanmış hali