Makro ile çok değişkenli düşeyara

[arda41]

Merhabalar,

Formül ile çok değişkenli düşeyara konusu daha önce forumda işlenmiş ve örnekler bulunmaktadır. Ancak makro yolu ile ekte yapmaya çalıştığıma benzer bir uygulamaya maalesef ulaşamadım. Yardımcı olabilecek herkese şimdiden çok teşekkür ederim.

Saygılarımla

 

[arda41]

Merhabalar,

Formül ile çok değişkenli düşeyara konusu daha önce forumda işlenmiş ve örnekler bulunmaktadır. Ancak makro yolu ile ekte yapmaya çalıştığıma benzer bir uygulamaya maalesef ulaşamadım. Yardımcı olabilecek herkese şimdiden çok teşekkür ederim.

Saygılarımla

Merhabalar,

Yardımcı olabilecek var mıdır arkadaşlar? Şimdiden çok teşekkür ederim.

Saygılarımla
İyi çalışmalar

 

[Muzaffer Ali]

Merhaba.
Çalışma adlı dosyanda Sayfa adını sağ tıklatın "Kod Görüntüle" seçin açılan sayfaya aşağıdaki kodları kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bak As Range
    Dim syfVeri As Worksheet
    Dim Karsilik As String
   
    If Not Intersect(Target, Range("A:A")) Is Nothing And Not Target = "" Then
        Set syfVeri = Workbooks("Veritabanı.xlsx").Worksheets("Sayfa1")
        For Each Bak In syfVeri.Range("A2:A" & syfVeri.Cells(Rows.Count, "A").End(xlUp).Row)
            If Bak.Text = Target.Text Then
                If Karsilik = "" Then
                    Karsilik = Bak(1, 2).Text
                Else
                    Karsilik = Karsilik & "," & Bak(1, 2).Text
                End If
            End If
        Next
        Application.EnableEvents = False
        If Karsilik = "" Then Karsilik = "..."
        Target(1, 2) = Karsilik
        Application.EnableEvents = True
    End If

Çalışma adlı dosyandaki sayfanın A sütununda bir değişiklik olduğunda istediğiniz işlem gerçekleşecektir.
Veritabanı adlı dosya mutlaka açık olmalıdır.

 

[arda41]

Merhaba.
Çalışma adlı dosyanda Sayfa adını sağ tıklatın "Kod Görüntüle" seçin açılan sayfaya aşağıdaki kodları kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bak As Range
    Dim syfVeri As Worksheet
    Dim Karsilik As String
  
    If Not Intersect(Target, Range("A:A")) Is Nothing And Not Target = "" Then
        Set syfVeri = Workbooks("Veritabanı.xlsx").Worksheets("Sayfa1")
        For Each Bak In syfVeri.Range("A2:A" & syfVeri.Cells(Rows.Count, "A").End(xlUp).Row)
            If Bak.Text = Target.Text Then
                If Karsilik = "" Then
                    Karsilik = Bak(1, 2).Text
                Else
                    Karsilik = Karsilik & "," & Bak(1, 2).Text
                End If
            End If
        Next
        Application.EnableEvents = False
        If Karsilik = "" Then Karsilik = "..."
        Target(1, 2) = Karsilik
        Application.EnableEvents = True
    End If

Çalışma adlı dosyandaki sayfanın A sütununda bir değişiklik olduğunda istediğiniz işlem gerçekleşecektir.
Veritabanı adlı dosya mutlaka açık olmalıdır.

Sayın DalgalıKur,

Çok teşekkür ederim. Elinize emeğinize sağlık.

Saygılarımla