Listedeki verinin karşılığını yazmak

[okreg]

Merhaba

Listeden Adı ve Soyadı bilgisini seçtiğimde tablodaki veri karşılıklarının sarı renkli sütuna yazmasını istiyorum

1- Mutlaka makro ile olmalı
2- isimleri sürekli güncelleyeceğim. yani tablodaki ad soyad sayısı ve buna bağlı veriler sayıca artacak

teşekkürler
okreg

 

[Ömer]

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim sut As Integer, c As Range, ilkadres As Variant
 
    If Intersect(Target, [C3:C4]) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Range("C6:C" & Rows.Count).ClearContents
    
    sut = Cells(1, Columns.Count).End(xlToLeft).Column
    With Range("E:E")
        Set c = .Find([C3], , xlValues, xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                If Cells(c.Row, "F") = Range("C4") Then
                    Range("G" & c.Row, Cells(c.Row, sut)).Copy
                    Range("C6").PasteSpecial xlPasteValues, xlNone, False, True
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    
    Target.Select: Set c = Nothing
    Application.CutCopyMode = False
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[İhsan Tank]

Merhaba

Listeden Adı ve Soyadı bilgisini seçtiğimde tablodaki veri karşılıklarının sarı renkli sütuna yazmasını istiyorum

1- Mutlaka makro ile olmalı
2- isimleri sürekli güncelleyeceğim. yani tablodaki ad soyad sayısı ve buna bağlı veriler sayıca artacak

teşekkürler
okreg

merhaba
alternatif olsun
boş bir module kopyalayın ve deneyin

Option Explicit
Sub karşılık()
Dim ts, kaplan, trabzonspor
kaplan = MsgBox(Range("C3") & Range("C4") & " Adlı Kişinin" _
& " Karşılıklarını Çıkarıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.ScreenUpdating = False
For ts = 2 To Cells(65536, "E").End(xlUp).Row
trabzonspor = 7
For kaplan = 6 To 14
If Cells(ts, "E") = Range("C3") And Cells(ts, "F") = Range("C4") Then
Cells(kaplan, "C") = Cells(ts, trabzonspor)
trabzonspor = trabzonspor + 1
End If
Next
Next
Application.ScreenUpdating = True
MsgBox Range("C3") & Range("C4") & " Adlı Kişinin" _
& " Karşılıklarını Çıkarttım", vbInformation, "Bitiş"
End Sub

 

[okreg]

çok teşekkürler Ömer bey

 

[okreg]

farklı bir yöntem için teşekkür ederim İhsan bey

 

[İhsan Tank]

farklı bir yöntem için teşekkür ederim İhsan bey

rica ederim
Syn : Ömer Hocam'ada teşekkür ederim.
:yazici: