ListBox seçimine bağlı satır aktarımı

[Hakan ERDOST]

Herkese merhaba bir listboxum var.bu listbox veritabanı a2:bn100 aralığındaki verilerden c2:c100 sütunundaki ad soyadı verilerini listeliyor.istediğim ise şu lisboxtaki seçime göre oluşturacağım kod ile ilgli kşiye ait tüm veriler yedek adlı sayfaya aktarılacak.aktarma kesip aktarma şeklinde olacak yani veritabanından aldıktan sonra alttaki satır yerine gelirken yedek syfasında dolu stırın altına aktarılacak.umarım anlatabildim.herkese kolay gelsin.

 

[Levent Menteşoğlu]

Dosyanızı eklermisiniz.

 

[Hakan ERDOST]

Dosyanızı eklermisiniz.

Sayın leventm bu daha önce yaptığım ve halen forumda bulunan okul uygulamasına bir arşiv ekleme çabamdır.Açılıştaki ana menüye Arşivleme diye bir buton ekledim butadan Userform1 üzerindegerekli nesneler eklenmiş durumda .Listbox1 deki seçime göre Butonaki kod Veritabanından alıp yedeğe gönderecek,yine aynı şekilde Listbox2 ise yedekten alıp veritabanına gönderecek.Teşekkürler.

 

[Hakan ERDOST]

Sayın leventm ekledim dosyayı bilginize.... Umarım kişiselleştirmedim.

 

[Levent Menteşoğlu]

Verdiğiniz şifre hatalı tekrar bakarmısınız.

 

[Hakan ERDOST]

Sayın leventm kusura bakmayın .Şifreyi kaldırıp ekliyorum.

 

[Levent Menteşoğlu]

Aşağıdaki kodları userform1 in kod sayfasına kopyalayın. Listbox2 yede aynı mantıkla kodlamayı yazarsınız. Listbox1in properties pencersinde rowsource özelliğine yazdığınız aralığıda kaldırmayı unutmayın.

Private Sub CommandButton1_Click()
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox1.ListIndex + 2
sonsat = WorksheetFunction.CountA(s2.[a:a]) + 1
s1.Range("b" & sat & ":z" & sat).Cut s2.Range("a" & sonsat)
s1.Range("b" & sat & ":z" & sat).Delete
s1.[a65536].End(3).ClearContents
UserForm_Initialize
End Sub

Private Sub UserForm_Initialize()
ListBox1.RowSource = "veritabani!c2:c100" & [veritabani!c65536].End(3).Row
ListBox2.RowSource = "yedek!b1:b" & [yedek!b65536].End(3).Row
End Sub

 

[Hakan ERDOST]

Private Sub CommandButton1_Click()
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox1.ListIndex + 2
sonsat = WorksheetFunction.CountA(s2.[c:c]) + 1
s1.Range("b" & sat & ":z" & sat).Cut s2.Range("c" & sonsat)
s1.Range("b" & sat & ":z" & sat).Delete
s1.[a65536].End(3).ClearContents
UserForm_Initialize
End Sub

Private Sub CommandButton2_Click()
Set s1 = Sheets("yedek")
Set s2 = Sheets("veritabani")
sat = ListBox1.ListIndex + 2
sonsat = WorksheetFunction.CountA(s2.[a:a]) + 1
s1.Range("b" & sat & ":z" & sat).Cut s2.Range("b" & sonsat)
s1.Range("b" & sat & ":z" & sat).Delete
s1.[a65536].End(3).ClearContents
UserForm_Initialize
End Sub

Private Sub UserForm_Initialize()
ListBox1.RowSource = "veritabani!c2:c100" & [veritabani!c65536].End(3).Row
ListBox2.RowSource = "yedek!c2:c" & [yedek!c65536].End(3).Row
End Sub

Kodlarınız arşive sorunsuz aktarıyor.
Ancak arşivden çağırmada sorunlar var .Satırı olduğu gibi almadığı gibi seçilen personeli bir üstekini aktarıyor.Belkide ben beceremedim.

 

[Levent Menteşoğlu]

Commandbutton2 ye aşağıdaki kodu yazın. Aslında bu sorunuz listboxtan diğer listboxa fare ile sürükle bırak şeklindede yapılabilir. Uygun bir zamanda böyle bir uygulamada eklerim.

Private Sub CommandButton2_Click()
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox2.ListIndex + 1
sonsat = WorksheetFunction.CountA(s1.[a:a]) + 1
s2.Range("a" & sat & ":z" & sat).Cut s1.Range("b" & sonsat)
s1.Range("a" & sonsat) = sonsat - 1
s2.Rows(sat).Delete
UserForm_Initialize
End Sub

 

[Hakan ERDOST]

Teşekkürler.Kolay gelsin.

 

[Levent Menteşoğlu]

Userform1in kod sayfasındaki tüm kodları silin ve yerine aşağıdakileri kopyalayın. Artık listbox1 ve listbox2 arasında fare ile seçilen veriyi tutup sürüleyerek aktarabilirsiniz. Böylece commandbuttonlarada gerek kalmayacaktır.

Private Sub UserForm_Initialize()
ListBox1.RowSource = "veritabani!c2:c100" & [veritabani!c65536].End(3).Row
ListBox2.RowSource = "yedek!b1:b" & [yedek!b65536].End(3).Row
End Sub
 
Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer _
, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Set veri = New DataObject
efekt = veri.StartDrag
End If
End Sub
 
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer _
, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Set veri = New DataObject
efekt = veri.StartDrag
End If
End Sub
 
Private Sub ListBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean _
, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject _
, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox2.ListIndex + 1
sonsat = WorksheetFunction.CountA(s1.[a:a]) + 1
s2.Range("a" & sat & ":z" & sat).Cut s1.Range("b" & sonsat)
s1.Range("a" & sonsat) = sonsat - 1
s2.Rows(sat).Delete
ListBox2.RowSource = ""
UserForm_Initialize
End Sub
 
Private Sub ListBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
 
Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
 
Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
    ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, _
    ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox1.ListIndex + 2
sonsat = WorksheetFunction.CountA(s2.[a:a]) + 1
s1.Range("b" & sat & ":z" & sat).Cut s2.Range("a" & sonsat)
s1.Range("b" & sat & ":z" & sat).Delete
s1.[a65536].End(3).ClearContents
ListBox1.RowSource = ""
UserForm_Initialize
End Sub

 

[Hakan ERDOST]

Userform1in kod sayfasındaki tüm kodları silin ve yerine aşağıdakileri kopyalayın. Artık listbox1 ve listbox2 arasında fare ile seçilen veriyi tutup sürüleyerek aktarabilirsiniz. Böylece commandbuttonlarada gerek kalmayacaktır.

Private Sub UserForm_Initialize()
ListBox1.RowSource = "veritabani!c2:c100" & [veritabani!c65536].End(3).Row
ListBox2.RowSource = "yedek!b1:b" & [yedek!b65536].End(3).Row
End Sub
 
Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer _
, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Set veri = New DataObject
efekt = veri.StartDrag
End If
End Sub
 
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer _
, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Set veri = New DataObject
efekt = veri.StartDrag
End If
End Sub
 
Private Sub ListBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean _
, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject _
, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox2.ListIndex + 1
sonsat = WorksheetFunction.CountA(s1.[a:a]) + 1
s2.Range("a" & sat & ":z" & sat).Cut s1.Range("b" & sonsat)
s1.Range("a" & sonsat) = sonsat - 1
s2.Rows(sat).Delete
ListBox2.RowSource = ""
UserForm_Initialize
End Sub
 
Private Sub ListBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
 
Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
 
Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
    ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, _
    ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox1.ListIndex + 2
sonsat = WorksheetFunction.CountA(s2.[a:a]) + 1
s1.Range("b" & sat & ":z" & sat).Cut s2.Range("a" & sonsat)
s1.Range("b" & sat & ":z" & sat).Delete
s1.[a65536].End(3).ClearContents
ListBox1.RowSource = ""
UserForm_Initialize
End Sub

Sayı leventm kodlar için teşekkürler.Listbox1 den 2 ye atarken sorun yok .Ancak Listbox2 den bire atarken ListBox2.RowSource = ""
Satırında hata veriyor.Birde bir açıklama yapayım veritabani sayfam 2 .satırdan başlıyor.Ancak veri aktarırken 1 . satırdan başladığı için sütun etiketlerinin üzerine yazıyor ve belirttiğim hatayı veryor.

 

[Hakan ERDOST]

sayın leventm sizi görmüşken hatırılatmak babından olsun.kusura bakmayın .Sorun bir önceki mesajımda.

 

[Levent Menteşoğlu]

Ben bahsettiğiniz gibi bir sorun göremedim. Ekli dosyayı inceleyin.

 

[Hakan ERDOST]

sayın leventm mutlaka test etmişsinizdir ama bende yine aynı hatayı verdi.şöyleki tüm kişileri arşive attım.burada sorun yok ama arşivden alırken ikinci kişide hata veriyor.(aynı satırda)

 

[Hakan ERDOST]

couldn't set rowsource property .Bu işlemi tamamlamak için kullanılbileek yeterli depolama alanı yok.Diye hata ve belirttiğim hata

 

[Levent Menteşoğlu]

Haklısınız gözümden kaçan hatalar varmış. Bu hataları düzelterek 14 nolu mesajımdaki dosyayı yeniledim, tekrar inceleyebilirsiniz.

 

[hikmet]

sn.hocam verdiğiniz bu örnekteki listboxlar arası mouse ile geçişte listbox2 deki satırların tekrar listbox1 e taşınmasını önlemek için ne yapabiliriz. listbox2 enable=false yaptığımızda listbox1 den 2 ye taşımıyor. listbox1 den ikiye taşıyabilsin ama 2 den 1 e geri taşıması önlensin. bu konuda değerli fikirlerinizi paylaşırmısınız.

 

[Levent Menteşoğlu]

Userformun kod sayfasında listbox2 ile ilgili tüm kodları kaldırın.

 

[Hakan ERDOST]

Sayın leventm çok teşekkürler.Güzel bir kod oldu.Birçok çalışmada sanırım kullanılacaktır.Kolay gelsin.