Listbox ile Hücreleri Aşağı Yukarı değiştirmek

[CengizYurek]

Merhabalar
Ekte dosyamı belirttim
Amacım sadece B3:B26 arasındaki hücrelerin yer değiştirmesini sağlayacak bir kod yazmak. Fakat ben sadece satırları değiştirebilecek düzeye gelebildim.
Sadece hücreyi aşağı yukarı yapabileceğim kodlamada yardımcı olabilir misiniz ?

Örneğin ilaç6yı yukarı tuşuna basarak 5-4-3-2-1 diye en üst sıraya kadar veya ilaç3ü aşağı tuşuyla sırayla 4-5-6-7ye kadar indirmek istiyorum. Ama satırlar değişmeyecek sadece b sütunundaki hücreler yer değiştirecek.

Teşekkür ederim.

 

[Muzaffer Ali]

Merhaba.
Formun kodlarını silin yerine aşağıdakileri yapıştırın.

Private Sub yukaribtn_Click()
    If ilacliste.ListIndex > 0 Then
        Cells(ilacliste.ListIndex + 3, "B").Cut
        Cells(ilacliste.ListIndex + 2, "B").Insert Shift:=xlDown
        ilacliste.List = Sheets("Sayfa1").Range("B3:B26").Value
    End If
End Sub

Private Sub asagibtn_Click()
    If ilacliste.ListIndex < ilacliste.ListCount - 1 Then
        Cells(ilacliste.ListIndex + 3, "B").Cut
        Cells(ilacliste.ListIndex + 5, "B").Insert Shift:=xlDown
        ilacliste.List = Sheets("Sayfa1").Range("B3:B26").Value
    End If
End Sub

Private Sub UserForm_Initialize()
    ilacliste.ColumnCount = 4
    ilacliste.List = Sheets("Sayfa1").Range("B3:B26").Value
End Sub

 

[CengizYurek]

Merhaba.
Formun kodlarını silin yerine aşağıdakileri yapıştırın.

Private Sub yukaribtn_Click()
    If ilacliste.ListIndex > 0 Then
        Cells(ilacliste.ListIndex + 3, "B").Cut
        Cells(ilacliste.ListIndex + 2, "B").Insert Shift:=xlDown
        ilacliste.List = Sheets("Sayfa1").Range("B3:B26").Value
    End If
End Sub

Private Sub asagibtn_Click()
    If ilacliste.ListIndex < ilacliste.ListCount - 1 Then
        Cells(ilacliste.ListIndex + 3, "B").Cut
        Cells(ilacliste.ListIndex + 5, "B").Insert Shift:=xlDown
        ilacliste.List = Sheets("Sayfa1").Range("B3:B26").Value
    End If
End Sub

Private Sub UserForm_Initialize()
    ilacliste.ColumnCount = 4
    ilacliste.List = Sheets("Sayfa1").Range("B3:B26").Value
End Sub

ya hocam çok çalışmaktan beynim durmuş. Cells yapacağıma Rows yapmışım. Çok teşekkür ederim emeğinize sağlık.

 

[Muzaffer Ali]

Tek sorun cells değil ama başka birkaç değişiklik daha yaptım. Eski kodlarla karşılaştırın.

 

[CengizYurek]

Tek sorun cells değil ama başka birkaç değişiklik daha yaptım. Eski kodlarla karşılaştırın.

gördüm hocam teşekkür ederim.