Seçilen ismin karşılık verilerini, düşey liste olarak getirmek

[EKREM1661]

Saygıdeğer Arkadaşlar! Ekli dosyada, açıklaması da yapılmış olan konuda; sayfa üstü combobox veya açılır liste kutusundan seçim yapılarak, belli bir aralıktaki yatay verilerin düşey liste halinde getirilmesi ile ilgili.. Yardımcı olacak arkadaşlar için minnettarım..

 

[Korhan Ayhan]

Deneyiniz.

"Sayfa2" isimli sayfanızın kod bölümüne uygulayınız.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range, X As Integer, Satir As Long
    
    If Intersect(Target, Range("B5")) Is Nothing Then Exit Sub
    
    Range("B6:B7,B11:B30").ClearContents
    Satir = 11
    Set Bul = Sheets("Sayfa1").Range("B:B").Find(What:=Target, LookAt:=xlWhole)
    
    If Not Bul Is Nothing Then
        Range("B6") = Sheets("Sayfa1").Cells(Bul.Row, 3)
        Range("B7") = Sheets("Sayfa1").Cells(Bul.Row, 4)
        For X = 6 To 36
            If Sheets("Sayfa1").Cells(Bul.Row, X) = "X" Then
                Cells(Satir, 2) = Sheets("Sayfa1").Cells(10, X)
                Satir = Satir + 1
            End If
        Next
        MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
    Else
        MsgBox Target & " isimli personel bulunamadı!", vbCritical
    End If

    Set Bul = Nothing
End Sub

 

[EKREM1661]

Korhan hocam.. Ziyadesiyle teşekkürler, harika olmuş.. Bu önceki çalışmamıza bir ilave idi, halledilmiş oldu.. Sağlıklı ömürler dileğiyle hoşça kalınız..

 

[EKREM1661]

Yalnız hocam, küçük bir pürüz oldu. B7 verisi başka sabit bir hücreden geldiği için,

Range("B7") = Sheets("Sayfa1").Cells(Bul.Row, 4)

satırını pasife aldım, yazmıyor. Ama bu defa B7 hücresine yazdığım başvuru formülünü de siliyor.?

 

[Korhan Ayhan]

Kodun bu bölümü bahsettiğiniz hücreleri temizliyor ve yerine yaptığınız seçime ait bilgileri getiriyor. Eğer siz B6-B7 hücrelerini farklı yerden formül ile aldırıyorsanjz koddan silmek gerekecektir.

Range("B6:B7,B11:B30").ClearContents

 

[EKREM1661]

Teşekkürler, üstad.. Düşünmeden acele etmişim.