1ci sayfadaki koda göre 2 ci sayfadaki satırı bul ve kopyala

[snx111]

2 sayfalı çalışma kitabım var; 1 ci (last) sayfadaki koda göre a4 ten başlıyor ;
2ci sayfadaki kodu bulucak buldugu satırı last sayfasındaki kodun karşısına o4 ten itibaren kopyalayacak ; mesela

last sayfasındaki 124 numaralı kodu sonuçlar sayfasının c sütununda arayacak
c stununda eşleşen kodu c4 ten m4 de kadar olan kısmını (sadece satırın ama)
1ci sayfanın e4 hücresinden itibaren yapıştırıcak

124 ajaccio troyes . 124 ajaccio troyes 1,75 3,20 3,20 1,80 1,55 2-3 2-3
125 vs... vs.... . 125 vs.. vs... 1,80 2,60 2,60 gibi

 

[mancubus]

forumda bu konu ile ilgili bir çok örnek var. lütfen üşenmeyelim, arayalım.

benzer bir kodu kullandığım için hazır olduğundan, uyarlamasını istisnai olarak ekliyorum.

Sub bul_kopya()

Dim bul_sat As Long, son_sat As Long
Dim cll As Range, rng As Range
Dim ara_alan As Range, bul_alan As Range
Dim krit As Variant

son_sat = Worksheets("LAST").Cells(Rows.Count, 1).End(3).Row

For Each cll In Worksheets("LAST").Range("A4:A" & son_sat)
    On Error Resume Next
        krit = cll.Value
    Set ara_alan = Worksheets("sonuçlar").Range("D4:D50000")
    Set bul_alan = ara_alan.Find(krit, LookIn:=xlValues, lookat:=xlWhole)
    If Not bul_alan Is Nothing Then
        bul_sat = bul_alan.Row
        Set rng = Worksheets("sonuçlar").Range("A" & bul_sat & ":M" & bul_sat)
        rng.Copy Destination:=Worksheets("LAST").Range("O" & cll.Row)
    End If
Next

End Sub

 

[snx111]

evet aradım buldum üzerinde degiştirmeler yaparak sorunumu çözdüm

Private Sub CommandButton2_Click()
Set S1 = Sheets("last")
Set s2 = Sheets("sonuçlar")
Set s3 = Sheets("yen")
s3.Cells.ClearContents
SATIR = 1
For x = 4 To S1.[a65536].End(3).Row
If S1.Cells(x, 1) <> "" Then
Set BUL = s2.[d4:d400].Find(S1.Cells(x, "a"), LookAt:=xlWhole)
If Not BUL Is Nothing Then
s2.Select
s2.Rows(BUL.Row).Select
Selection.Copy
s3.Select
s3.Rows(SATIR).Select
ActiveSheet.Paste
SATIR = SATIR + 1
End If
End If
Next
Sayfa13.Select
Set BUL = Nothing
Set S1 = Nothing
Set s2 = Nothing
Set s3 = Nothing
MsgBox "İşleminiz tamamlanmıştır.", vbInformation



End Sub


mancubusa teşekkür ederim senin kodlar daha hızlı çalışıyor