Döngü içerisinde döngü

[dogan081]

Değerli hocalarım,
Döngü çalışmalarını ve yayınlanan makaleleri inceledim, ancak hiçbirinde aradığım cevabı bulamadım. Amacım birden fazla bireyin soyağacını çıkartmak. Bireyin soy ağacı bulunduğu satırın sağ tarafına doğru artan bir şekilde gitmesi. Birey sayısı birden fazla olduğundan hem satırda hemde sütunda döngü oluşturması gerekiyor. Bu döngününde excel için hızlı çalışması lazım. Lütfen yardımınızı esirgemeyin. Kafayı çizmek üzereyim.

Not: örnek dosya hazırladım aşağıdaki linkte sundum. saygılar. Şimdiden teşekkür ediyorum.

http://dosya.co/3qxxfisqat8l/Ped.xlsm.html

 

[ccuneyt13]

Değerli hocalarım,
Döngü çalışmalarını ve yayınlanan makaleleri inceledim, ancak hiçbirinde aradığım cevabı bulamadım. Amacım birden fazla bireyin soyağacını çıkartmak. Bireyin soy ağacı bulunduğu satırın sağ tarafına doğru artan bir şekilde gitmesi. Birey sayısı birden fazla olduğundan hem satırda hemde sütunda döngü oluşturması gerekiyor. Bu döngününde excel için hızlı çalışması lazım. Lütfen yardımınızı esirgemeyin. Kafayı çizmek üzereyim.

Not: örnek dosya hazırladım ancak ekleyemedim. Bu konudada yardım edermisiniz. Bir ataç ekle butonu göremedim.

Merhaba,
Dosya eklemeyle ilgili bilgi vermek istedim.
Altın Üye olmayanlar dosya ekleme yapamıyor bu nedenle aşağıda yer alan yoldan faydalanabilir siniz.

"ALTIN ÜYE olmayanlar örnek belgeyi dosya.tc, dosya.co, dosyayukleyin.com gibi bir paylaşım sitesine yükleyip, belgeye erişim bağlantı adresini paylaşabilir."

 

[dogan081]

Merhaba,
Dosya eklemeyle ilgili bilgi vermek istedim.
Altın Üye olmayanlar dosya ekleme yapamıyor bu nedenle aşağıda yer alan yoldan faydalanabilir siniz.

"ALTIN ÜYE olmayanlar örnek belgeyi dosya.tc, dosya.co, dosyayukleyin.com gibi bir paylaşım sitesine yükleyip, belgeye erişim bağlantı adresini paylaşabilir."

Teşekkür ederim üstadım. birazdan ekleyeyim.

 

[veyselemre]

Sonuçların doğruluğunu test edin, kontrol edilmedi.

Dim dicBirey As Object
Dim sonSat
Dim veriler
Sub soyAgaci()
    Application.ScreenUpdating = False
    Set dicBirey = CreateObject("Scripting.Dictionary")
    sonSat = Cells(Rows.Count, "A").End(3).Row
    bireyler = Range("A4:A" & sonSat).Value
    veriler = Range("B4:C" & sonSat).Value

    Range("D4:O" & sonSat).Value = 0

    Dim babaAna(1 To 2)

    For i = 4 To sonSat
        birey = bireyler(i - 3, 1)
        babaAna(1) = veriler(i - 3, 1)
        babaAna(2) = veriler(i - 3, 2)
        dicBirey.Add birey, babaAna
    Next i

    Call Yaz(4)

    veriler = Range("D4:E" & sonSat).Value
    Call Yaz(8)

    veriler = Range("F4:G" & sonSat).Value
    Call Yaz(12)

End Sub

Sub Yaz(sutun As Integer)
    For i = 4 To sonSat
        baba = veriler(i - 3, 1)
        ana = veriler(i - 3, 2)

        If baba <> 0 And dicBirey.exists(baba) Then
            w = dicBirey(baba)
            Cells(i, sutun) = w(1)
            Cells(i, sutun + 1) = w(2)
        End If

        If ana <> 0 And dicBirey.exists(ana) Then
            w = dicBirey(ana)
            Cells(i, sutun + 2) = w(1)
            Cells(i, sutun + 3) = w(2)
        End If
    Next i

End Sub

 

[dogan081]

Veyselemre hocam Allah ne muradın varsa versin. Koca matrisi 4 - 5 saniye gibi bir zamanda doğru bir şekilde yaptı. Allah razı olsun herşey için.

 

[dogan081]

Sonuçların doğruluğunu test edin, kontrol edilmedi.

Veyselemre hocam Allah ne muradın varsa versin. Koca matrisi 4 - 5 saniye gibi bir zamanda doğru bir şekilde yaptı. Allah razı olsun herşey için.