Syf1 den syf2 ye olmayan kayıtları kopyalama ?

[Gorarr]

Selamlar burada ki işlev şu;

B sütunundaki bazı isileri belli renk dolgu ile işaretlediğimde, sayfa2 de de B sütununda aynı isim aynı renk dolgu ile işaretleniyor. (tabi bu otomatik olmuyor malesef, çift tıklamak gerekiyor)

ek olarak yapmaya çalıştığım ise şu ;
sayfa1 de renkle işaretlediğimde o isim sayfa2 de yoksa, o satır sayfa2 ye kopyalansın. Örnek dosyamda da açıkladım.

Yardımlarınız için çok çok teşekkürler..

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub Aktar()
    Dim i   As Long, _
        Son As Long, _
        Adt As Integer, _
        s2  As Worksheet, _
        Bul As Range
    
    Set s2 = Sheets("Sayfa2")
    
    Sheets("sayfa1").Select
    Son = s2.Cells(Rows.Count, "B").End(3).Row
    
    For i = 3 To Cells(Rows.Count, "A").End(3).Row
           Set Bul = s2.Range("B:B").Find(Cells(i, "B"), LookIn:=xlValues)
           If Bul Is Nothing Then
                Son = Son + 1
                Adt = Adt + 1
                Range("A" & i & ":G" & i).Copy s2.Cells(Son, "A")
                s2.Range("A" & Son) = s2.Range("A" & Son - 1) + 1
            End If
    Next i
    
    If Adt = 0 Then
        MsgBox "Aktarılacak Bir Kayıt Bulunamadı...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    Else
        MsgBox Adt & " Adet Kayıt Aktarıldı...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    End If
End Sub

 

[Gorarr]

Hocam teşekkür ederim. Benim bir sorum daha olacak onu belirtmeyi unutmuşum. Bu sizin kodlarınızın modifikasyonu ile olabilir sanırım.

Sayfa1 de isimlerini renklendirdiğim( sarı,mavi vss..) satırları sayfa2 ye taşımam gerekicek. Yeni bir örnek dosya ekledim.

Bu konuda da yardımcı olursanız çok çok sevinirim... saygılar..

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Aktar()
    Dim i   As Long, _
        Son As Long, _
        Adt As Integer, _
        s2  As Worksheet, _
        Bul As Range
    
    Set s2 = Sheets("Sayfa2")
    
    Sheets("sayfa1").Select
    Son = s2.Cells(Rows.Count, "B").End(3).Row
    
    For i = 3 To Cells(Rows.Count, "A").End(3).Row
        If Not Cells(i, "B").Interior.ColorIndex = xlNone Then
             Son = Son + 1
             Adt = Adt + 1
             Range("A" & i & ":G" & i).Copy s2.Cells(Son, "A")
             s2.Range("A" & Son) = s2.Range("A" & Son - 1) + 1
         End If
    Next i
    
    If Adt = 0 Then
        MsgBox "Aktarılacak Bir Kayıt Bulunamadı...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    Else
        MsgBox Adt & " Adet Kayıt Aktarıldı...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    End If
End Sub

 

[Gorarr]

Hocam ellerinize sağlık. Ama ufak bir sorun var butonu her tıkladığımda renklendirme olan satırları sayfa2 de aşağı doğru kopyalamaya devam ediyor. Eğer bir satır kopyalandıysa daha sonra kopyalamaması gerekicek. Bir kez daha bakabilirmisiniz çok sevinirim.

 

[Necdet]

Merhaba,

Sonra bakayım şimdi vaktim yok.

 

[Gorarr]

Tabiki nedemek nezaman uygun olursanız.

Buarada bir şey daha eklesem, sayfa2 ye taşırken numaralandırarak değilde komple tüm satırı kopyalayıp (çünkü kayıtlarım Z ye kadar gidecek) sayfa2 de boş olan son satıra kopyalayarak giderse tam istediğim gibi olacak.

Tekrardan teşekkür ederim.

 

[Necdet]

Merhaba,

Sub Aktar()
    Dim i   As Long, _
        Son As Long, _
        Adt As Integer, _
        s2  As Worksheet, _
        Bul As Range
    
    Set s2 = Sheets("Sayfa2")
    
    Sheets("sayfa1").Select
    Son = s2.Cells(Rows.Count, "B").End(3).Row
    
    For i = 3 To Cells(Rows.Count, "A").End(3).Row
        If Not Cells(i, "B").Interior.ColorIndex = xlNone Then
           [COLOR=red][B] Set Bul = s2.Range("B:B").Find(Cells(i, "B"), LookIn:=xlValues)
            If Bul Is Nothing Then
[/B][/COLOR]                Son = Son + 1
                Adt = Adt + 1
                Range("A" & i & ":G" & i).Copy s2.Cells(Son, "A")
                s2.Range("A" & Son) = s2.Range("A" & Son - 1) + 1
          [COLOR=red][B]  End If
[/B][/COLOR]         End If
    Next i
    
    If Adt = 0 Then
        MsgBox "Aktarılacak Bir Kayıt Bulunamadı...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    Else
        MsgBox Adt & " Adet Kayıt Aktarıldı...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    End If
End Sub

 

[Gorarr]

Rahmetli M.Jackson'un dediği gibi "this is it"

Çok teşekkür ederim hocam ellerinize sağlık. İnanılmaz derecede makbule geçti..

 

[Necdet]

Güle güle kullanınız.