Hücre içeriğine göre ara, bul, kopyala ve yapıştır

[yst10]

Merhabalar,
Bir sayfadaki kolon bilgilerine göre diğer sayfada arama yaptırmak ve eş olan verinin olduğu tüm satırı kopyalayıp, başka bir yere yapıştırmak istiyorum.
Örnek dosya ekte...
İlginize ve değerli fikirlerinize şimdiden teşekkür ederim.
Yavuz Tümer

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub BUL_AKTAR()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    S3.Cells.ClearContents
    SATIR = 1
    For X = 3 To S1.[D65536].End(3).Row
    If S1.Cells(X, 1) <> "" Then
    Set BUL = S2.[A:A].Find(S1.Cells(X, "D"), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    S3.Rows(SATIR).Value = S2.Rows(BUL.Row).Value
    SATIR = SATIR + 1
    End If
    End If
    Next
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    MsgBox "&#304;&#351;leminiz tamamlanm&#305;&#351;t&#305;r.", vbInformation
End Sub

 

[yst10]

Korhan hocam, iyi geceler.
Ne diyeyim, Allah Razı Olsun. Ellerine sağlık, gayet güzel olmuş, ellerine sağlık. Allaha emanet ol. Tekrar iyi geceler, eline, bilgine, yüreğine sağlık.
Sen beni sevindirdin, Allah seni sevindirsin. Hoşçakal.
Yavuz Tümer

 

[yst10]

Korhan hocam,
peki, eğer referans değerler 1 den fazla ise, yani arama kolonunda aynı kod 1 den fazla tekrar ediyorsa ve onları da seçmek gerekiyorsa ne yapılabilir?
Saygılar.
Yavuz Tümer

 

[yst10]

Korhan hocam,
peki, eğer referans değerler 1 den fazla ise, yani arama kolonunda aynı kod 1 den fazla tekrar ediyorsa ve onları da seçmek gerekiyorsa ne yapılabilir?
Saygılar.
Yavuz Tümer

Örnek dosya ekte hocam.

 

[yst10]

Korhan hocam günaydın,
Sanırım farketmedin mesajımı.

 

[yst10]

Korhan hocam,
imdat.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub CommandButton1_Click()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    S3.Cells.ClearContents
    SATIR = 1
    For X = 3 To S1.[D65536].End(3).Row
    If S1.Cells(X, 1) <> "" Then
    Set BUL = S2.[A:A].Find(S1.Cells(X, "D"), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    S3.Rows(SATIR).Value = S2.Rows(BUL.Row).Value
    SATIR = SATIR + 1
    Set BUL = S2.[A:A].FindNext(BUL)
    Loop While ADRES <> BUL.Address And Not BUL Is Nothing
    End If
    End If
    Next
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    MsgBox "&#304;&#351;leminiz tamamlanm&#305;&#351;t&#305;r.", vbInformation
End Sub

 

[yst10]

Korhan hocam,
Ellerin dert görmesin, mükemmel bir çalışma yapmışsın.
Çok ama çok teşekkür ederim.
Hoşçakal, iyi çalışmalar.
Yavuz Tümer