Koşula uyan değerleri taşımak

[batugul35]

Merhaba arkadaşlar

Ekli örnek dosya da açıkladığım gibi bir hücreye yazdığım değeri tabloda arayıp
onunile ilgili bilgileri diğer tarafa kopalamasını istiyorum.

Bunun ile ilgili yardımcı olabilirmisiniz.

Şimdiden herkeze teşekkürler

 

[Orion1]

Dosyanız ektedir.

Sub suz_59()
Dim k As Range, adr As String, sat As Long, sh As Worksheet
Dim sat2 As Long
Set sh = Sheets("Sheet1")
sat2 = 2
Application.ScreenUpdating = False
sh.Range("H2:J" & Rows.Count).ClearContents
sat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set k = sh.Range("A2:A" & sat).Find(sh.Range("B16").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        sh.Range("H" & sat2 & ":J" & sat2).Value = _
        sh.Range("A" & k.Row & ":C" & k.Row).Value
        Set k = sh.Range("A2:A" & sat).FindNext(k)
        sat2 = sat2 + 1
    Loop While Not k Is Nothing And k.Address <> adr
End If
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[batugul35]

çok teşekkür ederim.