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

[Levent Menteşoğlu]

Sn Hikmet bey Yukarıdaki mesajımı düzeltiyorum, Userformun kod sayfasındaki tüm kodları silin ve aşağıdakileri yerine kopyalayın.

Private Sub UserForm_Initialize()
son1 = [veritabani!c65536].End(3).Row
son2 = WorksheetFunction.CountA([yedek!b:b])
ListBox2.RowSource = ""
ListBox1.RowSource = ""
If son1 > 1 Then ListBox1.RowSource = "veritabani!c2:c" & son1
If son2 > 0 Then ListBox2.RowSource = "yedek!b1:b" & son2
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 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
ListBox1.RowSource = ""
ListBox2.RowSource = ""
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

 

[hikmet]

hocam teşekkür ederim emeğiniz için bende baya bir uğraştım ama malese listbox2 deki bilgileri silince çalışmıyordu şimdi çok güzel oldu teşekkürler tekrar elinize sağlık.

 

[ahmett46]

Slm Hocam
Programınızın son halini koyabilirmisiniz incelemek amaçlı. Bende bir okul programı yapıyorum. Kodlarınızdan faydalanabilirim. Ama ben acemiyim VBA da daha çok formülle yapıyorum. İyi çalışmalar.

 

[hikmet]

merhaba sn.hocalarım ve arkadaşlarım;
bu kodda listboxlar arası veri taşırken listboxda sadece bir sütun görünüyor listboxda 12 sütunun da görünmesi için kodda nasıl bir değişiklik yapmalıyım.
ilginiz için teşekkür ederim.

 

[emrexcel123]

rowsource ya da columncount

merhaba sn.hocalarım ve arkadaşlarım;
bu kodda listboxlar arası veri taşırken listboxda sadece bir sütun görünüyor listboxda 12 sütunun da görünmesi için kodda nasıl bir değişiklik yapmalıyım.
ilginiz için teşekkür ederim.

arkadaşım hücre aralığı doğruysa userform'un initialize olayına şu kodu ekle
ListBox1.ColumnCount = 12
eğer hücre aralığı yoksa rowsource olayında belirtmen yeterli

 

[Hakan ERDOST]

14. Mesajınızın ekindeki okul Excel uygulamasına bazı ilavler yapmaya çalıştım.Ancak şu anda arşivleme için kullandığım aşağıdaki kod

Dim ad As String
Private Sub UserForm_Initialize()
son1 = [veritabani!c65536].End(3).Row
son2 = WorksheetFunction.CountA([yedek!b:b])
ListBox2.RowSource = ""
ListBox1.RowSource = ""
If son1 > 1 Then ListBox1.RowSource = "veritabani!c2:c" & son1
If son2 > 0 Then ListBox2.RowSource = "yedek!b1:b" & son2
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)
ad = UserForm1.ActiveControl.Name
If ad = "ListBox1" Then Exit Sub
Cancel = True
Effect = fmDropEffectMove
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox2.ListIndex + 1
sonsat = WorksheetFunction.CountA(s1.[a:a]) + 1
ListBox1.RowSource = ""
ListBox2.RowSource = ""
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
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)
ad = UserForm1.ActiveControl.Name
If ad = "ListBox2" Then Exit Sub
Cancel = True
Effect = fmDropEffectMove
Set s1 = Sheets("veritabani")
Set s2 = Sheets("yedek")
sat = ListBox1.ListIndex + 2
sonsat = WorksheetFunction.CountA(s2.[a:a]) + 1
ListBox1.RowSource = ""
ListBox2.RowSource = ""
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

Aşağıdaki hatayı veriyor

Run-time error '-2147417848(80010108)
Methıd 'Cut' ıf object 'Range'failed

ve excel kasılıp kalıyor Taskbar dan kapatmak zorunda kalıyorum.Sorun ne olabilir.İlginç olan bir şeyde bazen bir pesoneli taşıdığımda sorun olmuyor ancak ikinci personeli arşive taşırken hatayı veriyor ve ondan sonra sürekli yapıyor.