AYNI MAKROYLA BİRDEN ÇOK SAYFAYA KAYIT YAPMAK

[oerbas]

AYNI MAKROYLA BÝRDEN ÇOK SAYFAYA KAYIT YAPMAK

Onayla dediğim zaman TextBoxlara girdiğim bilgilere gire bazı TextBoxlardaki bilgilerin Kasa sayfasına Bazı TaxtBoxlardaki bilgilerinde Carı Kart Sayfasına aktarılmasını istiyorum. Bu işlemi iki Ayrı komutla yapabiliyorum ama işi daha kolaylaştırmak istiyorum.

Bunun için aşağıdaki Makroyu yazdım ama hata veriyor yardımlarınızı bekliyorum.


Tüm Form çalışanlarına saygılarımla

Private Sub CommandButton6_Click()
'Kasa defteri kayıtları başlıyor
If TextBox4.Value = "" Then
Soru = MsgBox("Textbox4'e Veri Girmemişsiniz.Devam edeyimmi", vbYesNo, "Soru Başlığı")
TextBox4.SetFocus
If Soru = vbYes Then GoTo devam
If Soru = vbNo Then Exit Sub
End If
'TextBox1 veri girmemesi halinde ikaz
If TextBox1.Value = "" Then
Soru = MsgBox("Textbox1'e Veri Girmemişsiniz.Devam edeyimmi", vbYesNo, "Soru Başlığı")
TextBox1.SetFocus
If Soru = vbYes Then GoTo devam
If Soru = vbNo Then Exit Sub
End If
'TextBox2 veri girmemesi halinde ikaz
If TextBox2.Value = "" Then
Soru = MsgBox("Textbox2'e Veri Girmemişsiniz.Devam edeyimmi", vbYesNo, "Soru Başlığı")
TextBox2.SetFocus
If Soru = vbYes Then GoTo devam
If Soru = vbNo Then Exit Sub
End If
'TextBox3 veri girmemesi halinde ikaz
If TextBox3.Value = "" Then
Soru = MsgBox("Textbox3'e Veri Girmemişsiniz.Devam edeyimmi", vbYesNo, "Soru Başlığı")
TextBox3.SetFocus
If Soru = vbYes Then GoTo devam
If Soru = vbNo Then Exit Sub
End If
'TextBox4 veri girmemesi halinde ikaz
If TextBox4.Value = "" Then
Soru = MsgBox("Textbox4'e Veri Girmemişsiniz.Devam edeyimmi", vbYesNo, "Soru Başlığı")
TextBox4.SetFocus
If Soru = vbYes Then GoTo devam
If Soru = vbNo Then Exit Sub
End If
devam:
If TextBox1.Value <> "" Then
Sheets("Stok Listesi").Activate
Cells(3, 1).Select
Do While ActiveCell.Value <> ""
If Trim(ActiveCell.Value) = Trim(Me.TextBox15.Value) Then
If MsgBox(Me.TextBox15 & " Dosya Numaralı Ürün Kaydı Var" & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub
End If
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Value = TextBox1.Value
ActiveCell.Offset(0, 1).Value = TextBox2.Value
ActiveCell.Offset(0, 2).Value = TextBox3.Value
ActiveCell.Offset(0, 3).Value = TextBox4.Value
ActiveCell.Offset(0, 4).Value = TextBox5.Value
ActiveCell.Offset(0, 5).Value = TextBox6.Value
ActiveCell.Offset(0, 6).Value = TextBox7.Value
ActiveCell.Offset(0, 7).Value = TextBox8.Value
ActiveCell.Offset(0, 8).Value = TextBox9.Value
ActiveCell.Offset(0, 9).Value = TextBox10.Value
ActiveCell.Offset(0, 10).Value = TextBox11.Value
End If
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
End Sub

 

[xxrt]

Kodlarda ilgili yerlere siz kendi sayfanızı girin.

Private Sub CommandButton6_Click() 
....
...
..
devam: 
If TextBox1.Value <> "" Then 
Sheets("Stok Listesi").Activate 
Cells(3, 1).Select 
Do While ActiveCell.Value <> "" 
If Trim(ActiveCell.Value) = Trim(Me.TextBox15.Value) Then 
If MsgBox(Me.TextBox15 & " Dosya Numaralı Ürün Kaydı Var" & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub 
End If 
ActiveCell.Offset(1, 0).Activate 
Loop 
ActiveCell.Value = TextBox1.Value 
ActiveCell.Offset(0, 1).Value = TextBox2.Value 
ActiveCell.Offset(0, 2).Value = TextBox3.Value 
ActiveCell.Offset(0, 3).Value = TextBox4.Value 


'diyelimki Bundan sonrakileri Sayfa2'ye kaydedeceksiniz.
'Sheets("Sayfa2").Select ile verileri kaydetmek istediğiniz sayfaya geçiyor
'Range ("A1).Select Aktif hücreyi seçerek kaydı tamamlıyor.

ActiveCell.Offset(0, 4).Value = TextBox5.Value 
....
...
End Sub

Kodlar bende çalıştı.Sayfa isimlerine dikkat edin..Yada F8 ile kodu adımlıyarak hatanın nerede olduğunu bildirin.

 

[oerbas]

Sayın xxrt ye teşekkürler

verdiğiniz cevabı değerlendirip sorun çıkarsa size döneceğim hoşç kalın

 

[oerbas]

Sayın xxrt ye teşekkürler

verdiğiniz cevabı değerlendirip sorun çıkarsa size döneceğim hoşç kalın

Aşağıdaki kod aynı hatayı verdi

Private Sub CommandButton5_Click()
devam:
If TextBox14.Value <> "" Then
Sheets("Cari Kart").Activate
Cells(8, 1).Select
Do While ActiveCell.Value <> ""
If Trim(ActiveCell.Value) = Trim(Me.TextBox15.Value) Then
If MsgBox(Me.TextBox15 & " Dosya Numaralı Ürün Kaydı Var" & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub
End If
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Value = TextBox14.Value
ActiveCell.Offset(0, 1).Value = TextBox15.Value
ActiveCell.Offset(0, 2).Value = TextBox16.Value
ActiveCell.Offset(0, 3).Value = TextBox19.Value
'diyelimki Bundan sonrakileri Sayfa2'ye kaydedeceksiniz.
'Sheets("Sayfa2").Select ile verileri kaydetmek istediğiniz sayfaya geçiyor
'Range ("A1).Select Aktif hücreyi seçerek kaydı tamamlıyor.
Sheets("Kasa").Select
ActiveCell.Offset(1, 0).Activate
ActiveCell.Value = TextBox14.Value
ActiveCell.Offset(0, 1).Value = TextBox15.Value
ActiveCell.Offset(0, 2).Value = TextBox16.Value
ActiveCell.Offset(0, 3).Value = TextBox19.Value
Sheets("Kasa").Select
'Kasa sayfasına kayıtlar B8 hücresinden başlaması gerekiyor
Cells(8, 2).Select

'TextBox14 deki bilgiler B sütununa atılıyor
ActiveCell.Offset(0, 2).Value = TextBox14.Value
'TextBox17 deki bilgiler C sütununa atılıyor
ActiveCell.Offset(0, 3).Value = TextBox17.Value
'TextBox20 deki bilgiler E sütununa atılıyor
ActiveCell.Offset(0, 5).Value = TextBox20.Value
End Sub



Ã?rnek Dosyayı gönderiyorum dosya üzerinde yardımcı olabilirmisiniz

 

[oerbas]

Sayın xxrt Kardeşim ETOPLA Fonksiyonuna karşılık gelen Makro Başlığı altında bir soru sormuştum. Soduğum bu sorudan sonraki sorularıma cevap aldığım halda o sorum cevaplandırılmadı benim için hayli önemli olap bu konuda da yardımcı olursanız sevinirim

sağlıcakla kalınız

 

[xxrt]

Sayın xxrt Kardeşim ETOPLA Fonksiyonuna karşılık gelen Makro Başlığı altında bir soru sormuştum.

http://www.excel.web.tr/viewtopic.php?p=4354#4354

 

[xxrt]

Bu kodları denermisin..Yalnız kaydetmek istediğin hücrelerde veri doğrulama ile yapılmış kısımlar var.Onları halletmen gerek..

Private Sub CommandButton5_Click()
If TextBox14.Value <> "" Then
Sheets("Cari Kart").Activate
Cells(8, 1).Select
Do While ActiveCell.Value <> ""
If Trim(ActiveCell.Value) = Trim(Me.TextBox15.Value) Then
If MsgBox(Me.TextBox15 & " Dosya Numaralı Ürün Kaydı Var" & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub
End If
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Value = TextBox14.Value
ActiveCell.Offset(0, 1).Value = TextBox15.Value
ActiveCell.Offset(0, 2).Value = TextBox16.Value
ActiveCell.Offset(0, 3).Value = TextBox19.Value
'diyelimki Bundan sonrakileri Sayfa2'ye kaydedeceksiniz.
'Sheets("Sayfa2").Select ile verileri kaydetmek istediğiniz sayfaya geçiyor
'Range ("A1).Select Aktif hücreyi seçerek kaydı tamamlıyor.
Sheets("Kasa").Select
Range("B8").Select
ActiveCell.Offset(1, 0).Activate
ActiveCell.Value = TextBox14.Value
ActiveCell.Offset(0, 1).Value = TextBox15.Value
ActiveCell.Offset(0, 2).Value = TextBox16.Value
ActiveCell.Offset(0, 3).Value = TextBox19.Value
'Kasa sayfasına kayıtlar B8 hücresinden başlaması gerekiyor
'TextBox14 deki bilgiler B sütununa atılıyor
ActiveCell.Offset(0, 2).Value = TextBox14.Value
'TextBox17 deki bilgiler C sütununa atılıyor
ActiveCell.Offset(0, 3).Value = TextBox17.Value
'TextBox20 deki bilgiler E sütununa atılıyor
ActiveCell.Offset(0, 5).Value = TextBox20.Value
End If
End Sub

Aşağıdaki dosya biraz daha düzenlendi.Orjinal dosyanız değil.

 

[oerbas]

Yazılan Kodu denedim Kodun atandığı butonu tıkladığımda herhangi birşey olmuyor sanki bir makrro tanımlanmamış gibi oluyor. Ayrıca veri doğrulamaları kaldırdım

 

[xxrt]

O Kodda CommandButton5 olarak sendekine bir bakıver.Yada Enson ekteki dosyayı incelersen belki sorun hallolur..

 

[oerbas]

xxrt demişki
O Kodda CommandButton5 olarak sendekine bir bakıver.Yada Enson ekteki dosyayı incelersen belki sorun hallolur..

Sayın hocam dün akşam en son gönderdiğiniz örneği çalıştırdığımda kopyalanma olayı gerçekleşmişti. Tam o sıralarada mesai bitmiş servisler kalkmak üzereydi. Bende program çalıştı diyerek sevinmiştim. Sabah büyük bir merakla programı denedim. Yine, sanki KommandaButon 'a bir kod yazılmamış gibi bir durum var. bu sizin gönderdiğiniz dosyada da böyle benim dosyamdada. Ayrıca Bahsettiğiniz Veri doğrulamaları kaldırdım.

 

[xxrt]

dün akşam en son gönderdiğiniz örneği çalıştırdığımda kopyalanma olayı gerçekleşmişti.

k::

 

[oerbas]

Hocam Kod çok güzel çalışıyor hatada vermiyor fakat bir sorunumuz var çok uğraştım ama bir türlü çözemedim

Sorun Þu Cari kart kayıtları çok güzel yapılıyor Fakat Kasa Kayıtları Sürekli 9. satır üzerine yapılıyor. Yani bir sonraki kayıt bir önceki kaydı eziyor. Bu durumu çözmek için

'Sheets("Sayfa2").Select ile verileri kaydetmek istediğiniz sayfaya geçiyor kısmının arkasına aşağıdaki gibi bir ekleme yaptım

Range("B8").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("B1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Sheets("Kasa ").Select

yine olmadı hoşça kalın

 

[xxrt]

Bu Çalışmayı İnceleyin.