düşeyara ile renkli hücrelere karşılık gelen bilgi aktarımı

[penguen6363]

Selam Arkadaşlar

Ben ekli dosyadan da anlaşılacağı üzere kitap içindeki veri sayfasında C sütununda sarı renklerle işaretli hücrelere karşılık gelen J Sütunundaki bilgileri Sayfa1 deki G stunundaki isimlerinin karşılarına gelern rakamları aktarmak istiyorum düşey ara formülünü kullanıyorum ama renkli hücrelere karşılıkgelen rakamları nasıl aktaracağıma dair bir fikrim yok.
Yardımlarınız için şimdiden teşekürler.
Saygılar

 

[Korhan Ayhan]

Selamlar,

Bu işlemi yerleşik fonksiyonlarla yapamazsınız. Kullanıcı tanımlı fonksiyon yani makro yazmak gerekir.

 

[penguen6363]

Selamlar,

Bu işlemi yerleşik fonksiyonlarla yapamazsınız. Kullanıcı tanımlı fonksiyon yani makro yazmak gerekir.

Korhan bey

Malesef Makrolarle ilgili bilgim yok.Yardımcı olabilirmisiniz.

 

[penguen6363]

Bu konu hakkında yardım edecek yokmu

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu boş bir modüle ekleyiniz.

Hücrede kullanım şekli;

[B][COLOR=blue]=RENKLİ_DÜŞEYARA([COLOR=red]Aranan_Değer;Aranan_Dizi;Sütun_İndis_Sayısı;Renk_Kodu[/COLOR])[/COLOR][/B]

Option Explicit
 
Function RENKLİ_DÜŞEYARA(Aranan_Değer As Range, Aranan_Dizi As Range, Sütun_İndis_Sayısı As Integer, Optional Renk_Kodu As Byte = 6)
    Dim Bul As Range, Adres As String, Yeni_Adres As String, Sayfa_Adı As String
 
    Application.Volatile True
 
    Yeni_Adres = Aranan_Dizi.Resize(Aranan_Dizi.Rows.Count, _
    Aranan_Dizi.Columns.Count - (Aranan_Dizi.Columns.Count - 1)).Address
    Sayfa_Adı = Aranan_Dizi.Parent.Name
 
    With Sheets(Sayfa_Adı).Range(Yeni_Adres)
 
    Set Bul = .Find(Aranan_Değer, , xlValues, xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
            If Bul.Interior.ColorIndex = Renk_Kodu Then
                RENKLİ_DÜŞEYARA = Bul.Offset(0, Sütun_İndis_Sayısı - 1)
                Exit Do
            End If
        Set Bul = .Find(Aranan_Değer, Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
 
    End With
End Function

Renk kodu opsiyoneldir. Yani boş bıraktığınızda direk olarak sarı renkli hücreleri bulacaktır.

Ayrıca dosyanıza renk kodlarını gösteren bir sayfa ekledim. Bu sayfadaki kodları kullanarak istediğiniz renk koduna göre arama yapabilirsiniz.

Örnek dosya ektedir.

 

[penguen6363]

Korhan Bey

Vakit ayırıp zaman harcamışsınız.
Verdiğiniz emekten ötürü size sonsuz şükranlarımı sunuyorum.
Sağolun Var olun Elinize Beyninize sağlık
İyi Çalışmalar diliyorum

 

[penguen6363]

Korhan Bey

Bu makro ile farklı iki çalışma sayfasında bilgi alışverişi yapbilmem için ne yapmam gerekiyor
Birde şunu sormak istiyorum bu listelerden birinde (banka listesi) yazılı makro var bu eni makrolarla bir sıkıntı olurmu

 

[Korhan Ayhan]

Selamlar,

Aynı kitap içindeki sayfalar arasında bilgi alışverişi için kullanabilirsiniz. Ama kitaplar arası çalışmaz. Ekleme yapmak gerekecektir.

Diğer makrolarınız bu makroyu etkilemez. Rahatlıkla kullanabilirsiniz.

 

[Korhan Ayhan]

Selamlar,

Kitaplar arası için kodu aşağıdaki şekilde değiştirip kullanabilirsiniz. Fakat formülün sonuç üretmesi için iki kitabında açık olması gerekiyor.

Option Explicit
 
Function RENKLİ_DÜŞEYARA(Aranan_Değer As Range, Aranan_Dizi As Range, Sütun_İndis_Sayısı As Integer, Optional Renk_Kodu As Byte = 6)
    Dim Bul As Range, Adres As String, Yeni_Adres As String, Kitap_Adı As String, Sayfa_Adı As String
 
    Application.Volatile True
 
    Yeni_Adres = Aranan_Dizi.Resize(Aranan_Dizi.Rows.Count, _
    Aranan_Dizi.Columns.Count - (Aranan_Dizi.Columns.Count - 1)).Address
    Kitap_Adı = Aranan_Dizi.Parent.Parent.Name
    Sayfa_Adı = Aranan_Dizi.Parent.Name
 
    With Workbooks(Kitap_Adı).Sheets(Sayfa_Adı).Range(Yeni_Adres)
 
    Set Bul = .Find(Aranan_Değer, , xlValues, xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
            If Bul.Interior.ColorIndex = Renk_Kodu Then
                RENKLİ_DÜŞEYARA = Bul.Offset(0, Sütun_İndis_Sayısı - 1)
                Exit Do
            End If
        Set Bul = .Find(Aranan_Değer, Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
 
    End With
End Function

 

[penguen6363]

Teşekür ederim Korhan Bey

Yeni çalışma işimi gerçektende çok kolaylaştıracak

İyi Çalışmalar diliyorum.