Satırlar tamamlandığında sayfa 2'ye taşınsın

[temizerb]

Merhaba,

Mağazalarda kullanmak üzere bir dosya hazırladım, Bu dosyada bazı yerlerde düşeyara bazı yerlerde combobox var. Manuel giriş yaptıkları yer çok az ancak girişleri tamamladıklarında yani A'dan başlayıp M hücresini girdiklerinde ilgili satırın otomatik olarak o syafadan çıkıp aynı dosyada işlemi bitmiş sayfasına taşınmasını nasıl yapabiliriz.

 

[Ömer]

Merhaba,

Veri girişi yaptığınız sayfanın kod bölümüne kopyalayınız..

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bak As Range, S2 As Worksheet, son As Long
Set S2 = Sheets("Sayfa2")
son = S2.Cells(Rows.Count, "A").End(xlUp).Row + 1
If Intersect(Target, [M:M]) Is Nothing Then Exit Sub
Set Bak = Range("A" & Target.Row & ":M" & Target.Row)
    If WorksheetFunction.CountA(Bak) <> 13 Then
        MsgBox "A:M Sütunlarındaki Verileri Eksizsiz Giriniz"
        Exit Sub
    Else
        Bak.Copy S2.Range("A" & son)
    End If
End Sub

.

 

[temizerb]

Diğer kod ile karışırmı

Ömer hocam merhaba,

Saolasın senin sayende bayağı şeyler öğreniyorum, peki bir soru bu kodu daha önce senin yazdığın satır kilitleme kodunun altına kopyalasam sıkıntı olurmu ?

 

[Ömer]

Sizin amaçınız A ya veri girmeden B ye geçmesin sonra B ye girmeden C ye geçmesin ....şeklinde ilerleyerek M ye kadar gitmesi ve daha sonra diğer sayfaya kayıt yapması mı?

Eğer bu şekilde olacaksa;

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bak As Range, S2 As Worksheet, son As Long
Set S2 = Sheets("Sayfa2")
son = S2.Cells(Rows.Count, "A").End(xlUp).Row + 1
If Intersect(Target, [A:M]) Is Nothing Then Exit Sub
If Target.Column = 1 Then Exit Sub
Set Bak = Range("A" & Target.Row & ":M" & Target.Row)
Application.EnableEvents = False
    If WorksheetFunction.CountA(Bak) = 13 Then
        Bak.Copy S2.Range("A" & son)
    End If
    If Target.Offset(0, -1) = "" Then
        Target.ClearContents
        Target.Offset(0, -1).Select
        MsgBox ActiveCell.Address & " Hücresine Veri Girişi Yapınız."
    End If
Application.EnableEvents = True
End Sub

Kodları deneyiniz..

.

 

[temizerb]

Hata verdi

Ömer hocam merhaba,

Gönderdiğiniz kodları yine Sheet1'in kod bölümüne kopyaladım ancak - Set S2 = Sheets("Sayfa2") alanında hata veriyor, ne yapabilirim.

 

[Ömer]

Ömer hocam merhaba,

Gönderdiğiniz kodları yine Sheet1'in kod bölümüne kopyaladım ancak - Set S2 = Sheets("Sayfa2") alanında hata veriyor, ne yapabilirim.

Verilerin aktarılacağı sayfanın adı ne ?

Sayfa2

Ben bu şekilde tanımladım. Eğer farklı bir isimse kırmızı bölgeyi o isimle düzeltmeniz gerekir..

Set S2 = Sheets("Sheet2")

gibi..

.

 

[temizerb]

Sayfa İsmi

Hocam merhaba,

ingilizce kullanıyorum isterseniz dosyayı gönderebilirim üzerinden konuşabiliriz.

 

[temizerb]

Dosya

Dosyayı eklemeyi unuttum

 

[Ömer]

#6 nolu mesajda açıklamıştım..

Set S2 = Sheets("Sheet2")


.

 

[temizerb]

silinen kayıt yukarı taşınması

Merhaba hocam,

Süper olmuş ellerine sağlık peki A sayfasında tamamlanan bilgileri B sayfasına aktardıktan sonra A sayfasındaki taşınan satırı silmesi gerekli yoksa kayıtlar arasında boş satırlar kalıyor

 

[Ömer]

Merhaba hocam,

Süper olmuş ellerine sağlık peki A sayfasında tamamlanan bilgileri B sayfasına aktardıktan sonra A sayfasındaki taşınan satırı silmesi gerekli yoksa kayıtlar arasında boş satırlar kalıyor

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bak As Range, S2 As Worksheet, son As Long
Set S2 = Sheets("Sheet2")
son = S2.Cells(Rows.Count, "A").End(xlUp).Row + 1
On Error Resume Next
If Intersect(Target, [A:M]) Is Nothing Then Exit Sub
If Target.Column = 1 Then Exit Sub
Set Bak = Range("A" & Target.Row & ":M" & Target.Row)
Application.EnableEvents = False
    If WorksheetFunction.CountA(Bak) = 13 Then
        Bak.Copy S2.Range("A" & son)
        Rows(Target.Row).Delete
    End If
    If Target.Offset(0, -1) = "" Then
        Target.ClearContents
        Target.Offset(0, -1).Select
        MsgBox ActiveCell.Address & " Hücresine Veri Girişi Yapınız."
    End If
Application.EnableEvents = True
End Sub

.

 

[temizerb]

Dosya Korumaya alındığında çalışmıyor

Hocam merhaba,

Seni uğraştırdım ama ufak bir sorun var gönderdiğin kodları ekledim oldu fakat sayfa ve dosyayı kilitlediğimde çalışmıyor.

 

[Ömer]

Kusura bakmayın, işlerimin yoğunluğu nedeniyle geri dönüşüm geç oldu.

Kodları aşağıdakilerle değiştirin. abc yazan bölgelere kendi koruma şifrenizi yazarsınız..

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bak As Range, S2 As Worksheet, son As Long
Set S2 = Sheets("[COLOR=red]Sheet2[/COLOR]")
Application.ScreenUpdating = True
ActiveSheet.Unprotect "[COLOR=red]abc[/COLOR]"
If Intersect(Target, [A:M]) Is Nothing Then Exit Sub
Application.MoveAfterReturnDirection = xlToRight
son = S2.Cells(Rows.Count, "A").End(xlUp).Row + 1
Set Bak = Range("A" & Target.Row & ":M" & Target.Row)
If Target.Column = 1 Then Exit Sub
    Application.EnableEvents = False
        If WorksheetFunction.CountA(Bak) <> Target.Column Then
            Target.ClearContents
            Range("A" & Target.Row).End(xlToRight).Offset(0, 1).Select
        End If
        If WorksheetFunction.CountA(Bak) = 13 Then
            Bak.Copy S2.Range("A" & son)
            Rows(Target.Row).Delete
        End If
    Application.EnableEvents = True
ActiveSheet.Protect "[COLOR=red]abc[/COLOR]"
Application.ScreenUpdating = True
End Sub

Ayrıca veri girişinde kolaylık olması açısından enter'la ilerlemeyi sağa doğru yaptığım için ThisWokbook sayfasına aşağıdaki kodları kopyalayınız..

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.MoveAfterReturnDirection = xlDown
End Sub

.

 

[temizerb]

Satırları Taşımadı

Hocam ellerine sağlık seni uğraştırıyorum ama son kodları kopyaladım dediklerini yaptım ancak satırı diğer tarafa taşımıyor sheet 1'den silmiyor.

 

[Ömer]

Sayfa ismini değiştirmemiş, #13 nolu kodu düzenledim tekrar deneyiniz..

.

 

[temizerb]

En Son mesajı

Hocam selam,

Kusura bakma yeni gördüm en son yazdığın kod'dan basediyorsun değilmi dün akşam attığın yani

 

[Ömer]

#13 nolu mesaj diye yazmıştım. Mesajların sağ köşesinde mesaj numaraları bulunmaktadır. Buradan bulabilirsiniz.

.

 

[temizerb]

Hata Veriyor

Hocam selam,

senin verdiğin kodları yapıştırdım ancak ya ben yapamadım yada hatalı anlattım.

Dosyayı sana gönderiyorum yapmak istediğim ise şu ; Adamlar A Satırından itibaren M Satırına kadar yazmalılar ve bunu yaparken arada bazı kolonlar var bunlar vlookup ile gelecek ve datavalidation ile seçilecek. Tüm satırlar dolduğunda ise ilgili satır sayfa2'ye gidecek ve sayfa1'deki boş satır silinecek ki arada boşluk olmasın. Eğer yinede aklına takılan birşey varsa 5414293998'den ulaşabilirsin bana.

 

[egon77]

Ömer Bey çok emeğinize sağlık. Bir de kod satırlarını kısaca açıklasanız süper olacak bizim gibi excele gönül vermiş üyeleri çok sevindireceksiniz

 

[Ömer]

Hocam selam,

senin verdiğin kodları yapıştırdım ancak ya ben yapamadım yada hatalı anlattım.

Dosyayı sana gönderiyorum yapmak istediğim ise şu ; Adamlar A Satırından itibaren M Satırına kadar yazmalılar ve bunu yaparken arada bazı kolonlar var bunlar vlookup ile gelecek ve datavalidation ile seçilecek. Tüm satırlar dolduğunda ise ilgili satır sayfa2'ye gidecek ve sayfa1'deki boş satır silinecek ki arada boşluk olmasın. Eğer yinede aklına takılan birşey varsa 5414293998'den ulaşabilirsin bana.

Merhaba,

Yukarıda verdiğim kodlar bu işlemi yapıyor. Hata alıyorsanız kodları uyguladığınız dosyayı ekleyip hatayı nerden ve ne tür bir hata aldığınızı detaylı açıklayınız.

Ömer Bey çok emeğinize sağlık. Bir de kod satırlarını kısaca açıklasanız süper olacak bizim gibi excele gönül vermiş üyeleri çok sevindireceksiniz

Sayın egon77,

Açıklama yapmaya herzaman zamanım olmuyor maalesef. Konu çözüme kavuşunca açıklamaya çalışırım..

.