Ara bul yapıştır Yada Vlookup sorunu

[hüseyintok]

Merhaba örnekde kaynakdan codlara göre aktarılacak datada bulup yapıştırmak istiyorum. Vlookup ile diğer datalar bozuluyor. VBA olarak hangi yöntemle yapabilirim.
Teşekkürler

 

[hüseyintok]

Bu konu için aşağıdaki macroyu uyarlamaya çalışıyorum ama olmadı yardımcı olabilirmisiniz.

Sub ara()
On Error Resume Next

Dim i As String
Dim sat As Range

For i = 1 To 5 Step 1

Set sat = Worksheets("Sheet1").Range("M6:M10").Find(What:=i)

Sheet1.Range("N" & sat, "Q" & sat).Copy
s = WorksheetFunction.CountA(Sheet1.[c1:c65536])
Sheet1.Range("e" & s + 1).PasteSpecial Paste:=xlPasteValues

Next i
End Sub

 

[hüseyintok]

bu konuda yardımcı olabilecek kimse yok mu?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim Rng As Range, Find_Data As Range
    
    Application.ScreenUpdating = False

    For Each Rng In Range("C6:C" & Cells(Rows.Count, 3).End(3).Row)
        If IsNumeric(Rng) And Not IsEmpty(Rng) Then
            Set Find_Data = Range("M:M").Find(Rng, , , xlWhole)
            If Not Find_Data Is Nothing Then
                Find_Data.Offset(, 1).Resize(1, 4).Copy
                Rng.Offset(, 2).PasteSpecial xlPasteValues
            End If
        End If
    Next

    Range("A1").Select
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub