İki Çalışma Sayfasında eşleşen satırları 3.sayfaya aktarmak

[halukhaluk]

Benim sorunum şu , aynı çalışma kitabında 2 farklı sayfa var. 1. sayfada 900 kişilik bir liste var ve bu liste 2. sayfada ki 16000 kişilik listeden daha önce taranarak ayrılan isimler. İki sayfada ortak baz alacağım değer kayıtno sütunu. Şimdi yapmam gereken şu, 1. sayfada bulunan kayıtno lardan 2. sayfanın kayıtno lar sütununda eşleşen satırların 3. sayfaya kopyalanması. Şimdiden teşekürler...

 

[halukhaluk]

kimse yardım etmeyecek sanırım

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
Dim s1, s2, s3 As Worksheet
Dim sat1, sat2, s As Integer
Set s1 = Sayfa1
Set s2 = Sayfa2
Set s3 = Sayfa3
s3.[a2:g1000].ClearContents
s = 2
Application.ScreenUpdating = False
For sat1 = 2 To s1.Cells(65536, "a").End(xlUp).Row
For sat2 = 2 To s2.Cells(65536, "a").End(xlUp).Row
If s1.Cells(sat1, "a") Like s2.Cells(sat2, "a") Then
s3.Range("a" & s & ":g" & s).Value = s2.Range("a" & sat2 & ":g" & sat2).Value
s = s + 1
End If: Next: Next
Application.ScreenUpdating = True
MsgBox "işlem tamam", vbInformation
End Sub

 

[halukhaluk]

Hocam çok teşekkürler, ilginiz ve duyarlılığınız için..
Makroyu çalıştırdım, şu an halen işlem yapmakta. Sanırım çalışma dosyamın büyük olmasından kaynaklanıyor. Fakat örnek dosya üzerinde çalıştığına göre ana dosyadada işe yarayacağını sanıyorum. Elinize emeğinize sağlık. Saygılarımla...

 

[halukhaluk]

Beni 1 günlük iş yükü ve kafa yorgunluğundan kurtardınız. Sonsuz Teşekkürler....

 

[Orion1]

Alternatif;
Hız açısından aşağıdaki kodlarıda kendi dosyanızda denermisiniz.
Sonucuda söylerseniz memnun olurum.

Sub karsilastir_aktar()
Dim i As Long, sat As Long, k As Range, s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Sheets("Sayfa3").Select
sat = 2
Range("A2:G65536").ClearContents
Application.ScreenUpdating = False
For i = 1 To s1.Cells(65536, "A").End(xlUp).Row
    Set k = s2.Range("A2:A65536").Find(s1.Cells(i, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Range(Cells(sat, "A"), Cells(sat, "G")).Value = _
        s2.Range(s2.Cells(k.Row, "A"), s2.Cells(k.Row, "G")).Value
        sat = sat + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır..", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[bluefalcon]

süper bir çalışma elinize sağlık.