Hücrelerde aratıp yanına yazdırma

[Rudolph]

Merhaba arkadaşlar. Çifliğimizde kullanmak üzere bizi büyük bir dertten kurtaracak bir tablo yapmak istiyorum. Fakat fazla formül bilgim olmadığı için yapamadım.

http://i.hizliresim.com/gk3Dn0.png

Yukarıdaki resimde küpe kısmındaki hayvanlara tohumlama yapacağız. Ancak yapacağımız tohumlama, hayvanın babası ve soy kısmının ilk sütünu yani dedesi olmamalıdır.

Sağ tarafta bulunan kısım ise, atacağımız tohumlar. Bunlarında babası ve dedeleri yanına yazılmış.

1.öneri sutünuna bu sperma alanıyla (baba ve dede alanı) küpe numarasının yanındaki baba ve soy kısmındaki ilk sutünü karşılaştıracak ve birbirine uyuşmayanları yazacak. Baba ve sperma babası, baba ve sperma dedesi karşılaştırılmalı ve aynı olmayanlar yazılmalı. Yoksa akraba çiftleşmesi gerçekleşecektir.

Bu konuda yardım edebilirseniz çok sevinirim ve bizi çok büyük bir işten kurtarmış olursunuz.

 

[Erdem Akdemir]

Merhaba,

İşyerinde internet filtresi var. Örnek dosyanızı aşağıdaki adrese yükleyerek paylaşabilir misiniz?

http://dosyadepo.com/

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Makrodaki sütunları verdiğiniz resme göre küpe A sütununda, 1. Öneri G sütununda ve Sperma M sütununda olduğunu hesaplayarak ayarladım:

Sub TOHUM()
sont = Cells(Rows.Count, "M").End(3).Row
sonk = Cells(Rows.Count, "A").End(3).Row

For i = 2 To sonk
    For j = 2 To sont
        If WorksheetFunction.CountIf(Range(Cells(j, "M"), Cells(j, "O")), Cells(i, "B")) = 0 And WorksheetFunction.CountIf(Range(Cells(j, "M"), Cells(j, "O")), Cells(i, "C")) = 0 Then
            If Cells(i, "G") = "" Then
                Cells(i, "G") = Cells(j, "M")
            Else
            If Cells(i, "H") = "" Then
                Cells(i, "H") = Cells(j, "M")
            Else
            If Cells(i, "I") = "" Then
                Cells(i, "I") = Cells(j, "M")
            Else
            If Cells(i, "J") = "" Then
                Cells(i, "J") = Cells(j, "M")
            End If
            End If
            End If
            End If
        End If
    Next
Next
            
End Sub

 

[Rudolph]

ne kadar teşekkür etsem azdır. Allah razı olsun. çok sağolun ikinizde ilgilendiğiniz için.

bir ricam olacak bu satırların mantığını işlerini söyleyebilir misiniz başka sütunlarda kullanabilirim.

 

[YUSUF44]

sont ile M sütunundaki son dolu hücreyi (sperma sayısını da diyebiliriz) belirliyoruz.
sonk ile A sütunundaki son dolu hücreyi (küpe sayısını da diyebiliriz) belirliyoruz.

For i = 2 To sonk kısmında 2. satırdan yani ilk küpeden itibaren son küpeye kadar bir şeyler yapmasını istiyoruz.

For j = 2 To sont kısmında önceki satırla bağlantılı olarak her küpe için ayrı ayrı tohum değerlendirmesi yapmasını istiyoruz

If WorksheetFunction.CountIf(Range(Cells(j, "M"), Cells(j, "O")), Cells(i, "B")) = 0 And WorksheetFunction.CountIf(Range(Cells(j, "M"), Cells(j, "O")), Cells(i, "C")) = 0 Then
kısmında küpenin soyuyla spermanın soyunun karşılaştırmasını EĞERSAY formülünü kullanarak yapıyoruz. Babasının/dedesinin adı sperma listesinde yoksa diyoruz.

If Cells(i, "G") = "" Then
Cells(i, "G") = Cells(j, "M")
Else
If Cells(i, "H") = "" Then
Cells(i, "H") = Cells(j, "M")
Else
If Cells(i, "I") = "" Then
Cells(i, "I") = Cells(j, "M")
Else
If Cells(i, "J") = "" Then
Cells(i, "J") = Cells(j, "M")
End If
End If
End If
End If

Kısmında önceki satırda yaptığımız değerlendirmeye göre boş olan öneri sütunlarını dolduruyoruz.

Diğer kısımlar ise yaptığımız işlemleri sonlandırdığımız kısımlar.

 

[Rudolph]

Yusuf bey çok çok teşekkür ederim. çok yardımcı oldunuz sağolun.

 

[YUSUF44]

Önemli değil. Ziraat mühendisi ve hatta büyükbaş çiftliği ortağı biri olarak çalışmanız benim de ilgimi çekti. Güzel düşünmüşsünüz.