Karşılaştı Tutarsa Kopyala

[alperalper]

Arkadaşlar aşağıdaki vereceğim dosyayı kotrol edebilirmisiniz. Ben bir türlü birleştiremedim. Bilen arkadalların yardımına ihityacım var acil....

örnek çalışma kitabında 2 nolu sayfada F,G VE H DE YAZAN VERİLERİ 1 NOLU ÇALIŞMA sayfasında F,G,H İLE
KARŞILAŞTIRACAK VE UYUŞAN VERİLER VARSA 1 NOLU sayfadan B,C,D,E Yİ 2 NOLU sayfa İÇİNDEKİ B,C,D,E YE YAZACAK.

 

[leumruk]

Merhaba,
Her iki sayfadan birinin b1 hücresine çift tıkladığınızda kod çalışır.

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If ActiveSheet.Name = "1" Or ActiveSheet.Name = "2" Then
If Intersect(Target, [b1]) Is Nothing Then Exit Sub
Cancel = True
Set s1 = Sheets("1")
Set s2 = Sheets("2")
Set Aralik = s2.Range("h2:h" & s2.[h65536].End(3).Row)
Application.ScreenUpdating = False
For x = 2 To s1.[h65536].End(3).Row
    Set Bul = Aralik.Find(s1.Cells(x, "h"), LookAt:=xlWhole)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            If s1.Cells(x, "g") = s2.Cells(Bul.Row, "g") And s1.Cells(x, "f") = s2.Cells(Bul.Row, "f") Then
            s1.Range("b" & x & ":e" & x).Copy: s2.Cells(Bul.Row, "b").PasteSpecial Paste:=xlValues
            Say = Say + 1
            End If
            Set Bul = Aralik.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
        Application.CutCopyMode = False
    End If
Next
If Say > 0 Then
MsgBox "İşlem tamamlanmıştır. Aktarılan veri sayısı: " & Say, vbInformation, "leumruk"
Else
MsgBox "Aktaracak veri kaydı bulunamadı.", vbCritical, "leumruk"
End If
End If
End Sub