Kodlama ağacına uygun olarak aynı düzen içinde karşılığını çağırma

[ATEMİ]

Merhabalar;
Sistematik bir kodlama ağacım var bağımsız bir hücreye yazacağım kod ile karşılığı bu sistematiğe uygun olarak gelsin istiyorum. Yardımcı olabilirseniz sevinirim.

 

[Ömer]

Merhaba,

Deneyiniz.

Sub test()

    Dim i As Byte, d As String, s As Byte, j As Integer, sat As Long, c As Range, sut As Integer

    Application.ScreenUpdating = False
    Range("K4:K10").ClearContents
        
    For i = 4 To 10
        If Cells(i, "J") <> "" Then
            d = "": s = 0
            Set c = [A:G].Find(Cells(i, "J"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                sut = c.Column
                If sut > 1 Then
                    For j = 1 To sut
                        If j = sut Then s = 1
                        sat = Cells(c.Row + s, j).End(xlUp).Row
                        d = d & " / " & Cells(sat, j + 1)
                    Next j
                    Cells(i, "K") = WorksheetFunction.Substitute(d, " / ", "", 1)
                Else
                    Cells(i, "K") = Cells(c.Row, sut + 1)
                End If
            End If
        End If
    Next i
    
    Range("K4:K10").WrapText = False
    Application.ScreenUpdating = True
    
End Sub

 

[ATEMİ]

Ömer Mey Merhaba;
Geri dönüşünüz ve emeğiniz için çok teşekkür ederim.
Bu kodlardan çok anlamıyorum fonksiyonlu çözüm bulamazmıyız

 

[ATEMİ]

Herhangi bir hücreye yazacağımız bir formülle hemen solundaki hücreye esas alarak sistematik olarak çağırması mümkün olmaz mı?

 

[Ömer]

Aşağıdaki kodları VBA ekranına geçip standart bir module kopyalayın. Daha sonra formülün sonuçlanmasını istediğiniz hücreye;

Örneğinize göre;
=agac_liste_olustur(A:H;J4)

Yazarsanız formül gibi istediğiniz sonuçları alırsınız. Buradaki A:H aranan aralık, J10 ise aranacak değerdir. Formül gibi içeriği değiştirebilirsiniz.

Function agac_liste_olustur(alan As Range, hcr As Range)
 
    Dim d As String, s As Byte, j As Integer, sat As Long, c As Range, sut As Integer
 
    Application.Volatile True
    If hcr = "" Then agac_liste_olustur = "": Exit Function
 
    d = "": s = 0
    Set c = [alan].Find(hcr, , xlValues, xlWhole)
    If Not c Is Nothing Then
        sut = c.Column
        If sut > 1 Then
            For j = 1 To sut
                If j = sut Then s = 1
                sat = Cells(c.Row + s, j).End(xlUp).Row
                d = d & " / " & Cells(sat, j + 1)
            Next j
            agac_liste_olustur = WorksheetFunction.Substitute(d, " / ", "", 1)
        Else
            agac_liste_olustur = Cells(c.Row, sut + 1)
        End If
    End If
 
End Function

Ekte tarif edilenler uygulanmıştır.

.

 

[ATEMİ]

Ömer bey çok güzel olmuş elinize sağlık
peki ben hücrelerin yerini değiştirmek istesem nasıl yapmam gerekiyor

 

[Ömer]

Yukarıda tarif etmiştim.

=agac_liste_olustur(A:H;J4)

Formülün içindeki A:H ve J4 olan bölümlere değiştirdiğiniz alanları yazmanız gerekir. Formül gibi düşünün.

 

[ATEMİ]

Ömer Bey çok teşekkür ederim harikasınız

 

[ATEMİ]

Ömer bey formülü bir diğer sayfaya taşıdım kodu yazdığımda ana sayfaya ilgili hücrenin içine girmeden sonucu getirmiyor bunun için ne yapmalıyım

 

[Ömer]

Kodları silip aşağıdaki yeni kodları aynı bölüme yapıştırın.

Function agac_liste_olustur(alan As Range, hcr As Range)
 
    Dim d As String, s As Byte, j As Integer, sat As Long, c As Range, sut As Integer, S1 As Worksheet
    
    Set S1 = Sheets("Ürün Ağacı")
 
    Application.Volatile True
    If hcr = "" Then agac_liste_olustur = "": Exit Function
 
    d = "": s = 0
    Set c = [alan].Find(hcr, , xlValues, xlWhole)
    If Not c Is Nothing Then
        sut = c.Column
        If sut > 1 Then
            For j = 1 To sut
                If j = sut Then s = 1
                sat = S1.Cells(c.Row + s, j).End(xlUp).Row
                d = d & " / " & S1.Cells(sat, j + 1)
            Next j
            agac_liste_olustur = WorksheetFunction.Substitute(d, " / ", "", 1)
        Else
            agac_liste_olustur = S1.Cells(c.Row, sut + 1)
        End If
    End If
 
End Function

 

[ATEMİ]

Evet şimdi oldu teşekkür ederim