Girilen kaydı firma adına göre ayrı ayrı sayfalara kopyalama

[msetr]

İyi günler,

Forumda araştırdım şöyle bir kod buldum.

sayfa1 sekmesine sağ klik yapıp kod görrüntüle diyin..çıkan ekrana alttaki kodu kopyalayın..sayfa1 de m sutununa KENARDA yazdığınız zaman satır kopyalancaktır..

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [m:m]) Is Nothing Then Exit Sub
If Target = "KENARDA" Then
Rows(Target.Row).Copy
Sheets(2).Range("a" & Target.Row).PasteSpecial
End If
Application.CutCopyMode = False
End Sub

Benim istediğim veri giriş sayfasına girmiş olduğum kayıtları firma firma ayrı sayfalara kopyalasın.

Mesela sayfa1 veri giriş sayfası abc firmasına ait fatura girdiğimde satırı abc sayfasına kopyalasın. Aynı şekilde Def firmasına ait fatura girdiğimde onuda Def sayfasına kopyalasın. Satırların üzerine yazmadan kaydırma yaparak alt alta kopyalabilirmiyiz. Tek firma için tamamda çoklu olunca çözemedim.

Yardımcı olacak arkadaşlara şimdiden teşekkürler.

 

[muygun]

Örnek dosya ekleyin.

 

[msetr]

Örnek dosya ekte.


http://www.dosyaupload.com/daQY

 

[YUSUF44]

Aşağıdaki kodları VERİ sayfasının kod bölümüne yapıştırın. L sütununa bilgi girdiğinizde ve satırdaki diğer hücreler de doluysa ilgili sayfaya aktarma yapar:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("L2:L" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
If WorksheetFunction.CountBlank(Range("A" & a & ":L" & a)) = 0 Then
    For sayfa = 1 To Sheets.Count
        If Sheets(sayfa).Name = Target Then
            yeni = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row + 1
            Range("A" & a & ":K" & a).Copy Sheets(sayfa).Cells(yeni, "A")
            sayfa = Sheets.Count
        End If
    Next
End If
End Sub

 

[msetr]

Çok teşekkür ederim Yusuf Bey.

Kod çalışıyor ama şöyle bir durum var. L sütununa yanlışlıkla tekrar birşey yazarsam aynı satırı tekrar kopyalıyor. Bu hatayı nasıl engelleyebiliriz.

 

[YUSUF44]

Aşağıdaki şekilde kullanırsanız aktarılanların M sütununa "Aktarıldı" yazar ve M sütununda "Aktarıldı yazan satırı yeniden aktarmaz:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("L2:L" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
If Target.Offset(0, 1) <> "Aktarıldı" Then
    If WorksheetFunction.CountBlank(Range("A" & a & ":L" & a)) = 0 Then
        For sayfa = 1 To Sheets.Count
            If Sheets(sayfa).Name = Target Then
                yeni = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row + 1
                Range("A" & a & ":K" & a).Copy Sheets(sayfa).Cells(yeni, "A")
                sayfa = Sheets.Count
                Target.Offset(0, 1) = "Aktarıldı"
            End If
        Next
    End If
End If
End Sub

 

[msetr]

Evet şimdi tamam oldu. Teşekkürler hayırlı Ramazanlar.