İşletmedeki Sığır Listesinden Dişi Erkek Sayısını Çıkarma

[bayhekim81]

Tablo1, Tablo2'ye dönüştürülebilir mi?

 

[ÖmerBey]

Tablo1 isimli dosyanıza Tablo adında bir sayfa daha ekleyip aşağıdaki kodu çalıştırınız.

Sub kod()
Set s1 = Sheets("RP1144IsletmedekiHayvanBilgisi")
Set s2 = Sheets("[COLOR="red"]Tablo[/COLOR]")
For a = 13 To s1.Range("A65500").End(3).Row
    If s1.Cells(a, "A") = "İŞLETME NO" Then
        sat = s2.Range("A65500").End(3).Row + 1
        d = 0
        e = 0
        s2.Cells(sat, "A") = s1.Range("G6")
        s2.Cells(sat, "B") = s1.Range("G7")
        s2.Cells(sat, "C") = s1.Range("G8")
        s2.Cells(sat, "D") = Replace(s1.Cells(a, "C"), ": ", "")
        s2.Cells(sat, "E") = Split(Replace(s1.Cells(a + 1, "C"), ": ", ""), "-")(1)
        s2.Cells(sat, "F") = Split(Replace(s1.Cells(a + 1, "C"), ": ", ""), "-")(0)
        b = a
        
        Do
            b = b + 1
            If s1.Cells(b, "I") = "DİŞİ" Then
                d = d + 1
            ElseIf s1.Cells(b, "I") = "ERKEK" Then
                e = e + 1
            End If
        Loop Until s1.Cells(b, "A") = "İŞLETME NO" Or b > s1.Range("A65500").End(3).Row
        
        s2.Cells(sat, "G") = d
        s2.Cells(sat, "H") = e
        s2.Cells(sat, "I") = d + e
    End If
Next
End Sub

 

[bayhekim81]

5000 satırlı bir Tablo için geçerli mi

Öncellikle teşekkür ederim makro çalışıyor 5000 satırlı bir Tablo için geçerli mi bu kod? Yada en fazla kaç satıa kadar çevirebilir?

 

[YUSUF44]

Aşağıdaki satır A sütunundaki son dolu satıra kadar işlem yapılacağını gösteriyor:

For a = 13 To s1.Range("A65500").End(3).Row

 

[ÖmerBey]

Yusuf Bey'in belirttiği gibi kod, A sütunundaki dolu olan son satıra kadar çalışır. Ancak dosyanızda biçim ve sütun farkı var ise hatalı çalışacak ya da yanlış sayım yapacaktır.

Bir de alternatif olarak aşağıdaki kodu deneyiniz. Mantık olarak aynı işlemi yapıyor ama daha hızlı çalışacaktır.

Sub kod2()
Set s1 = Sheets("RP1144IsletmedekiHayvanBilgisi")
Set s2 = Sheets("Tablo")
Set baş = s1.Range("A:B").Find("İŞLETME NO", , , xlWhole)
Do
    Set son = s1.Range("A:B").FindNext(baş)
    If son.Row < baş.Row Then Set son = s1.Range("A65500").End(3)
    sat = s2.Range("A65500").End(3).Row + 1
    s2.Cells(sat, "A") = s1.Range("G6")
    s2.Cells(sat, "B") = s1.Range("G7")
    s2.Cells(sat, "C") = s1.Range("G8")
    s2.Cells(sat, "D") = Replace(s1.Cells(baş.Row, "C"), ": ", "")
    s2.Cells(sat, "E") = Split(Replace(s1.Cells(baş.Row + 1, "C"), ": ", ""), "-")(1)
    s2.Cells(sat, "F") = Split(Replace(s1.Cells(baş.Row + 1, "C"), ": ", ""), "-")(0)

    s2.Cells(sat, "G") = WorksheetFunction.CountIf(s1.Range(s1.Cells(baş.Row, "I"), s1.Cells(son.Row, "I")), "DİŞİ")
    s2.Cells(sat, "H") = WorksheetFunction.CountIf(Range(s1.Cells(baş.Row, "I"), s1.Cells(son.Row, "I")), "ERKEK")
    s2.Cells(sat, "I") = s2.Cells(sat, "G") + s2.Cells(sat, "H")
    
    Set baş = son
Loop Until son.Address = s1.Range("A65500").End(3).Address
End Sub