Hücreleri Sola Kaydırma

[ahmed_ummu]

Merhaba arkadaşlar.

Aşağıdaki kod ile aktif satırın DO ve EL sütunları arasındaki verileri sildiriyorum.

Listbox'1 den 1. sırdaki veri seçilirse,
DO-DR aralığındaki verileri yani sağa doğru 4 hücre

Listbox'1 den 2. sırdaki veri seçilirse,
DS-DV aralığındaki verileri yani sağa doğru 4 hücre

Listbox'1 den 3. sırdaki veri seçilirse,
DW-DZ aralığındaki verileri yani sağa doğru 4 hücre

Listbox'1 den 4. sırdaki veri seçilirse,
EA-ED aralığındaki verileri yani sağa doğru 4 hücre

Listbox'1 den 5. sırdaki veri seçilirse,
EE-EH aralığındaki verileri yani sağa doğru 4 hücre

Listbox'1 den 6. sırdaki veri seçilirse,
EI-ELaralığındaki verileri yani sağa doğru 4 hücre

Siliniyor ve hücreler sola kaydırılıyor. Bu veriler DO-EL sütunlarında. Sola kayma son verinin bulunduğu EL sütunundan sonra ki sütunlarıda sola kaydırıyor. Sola kayma sadece aktif satırın DO-EL sütunları arasında olacak. İşin içinden çıkamadım, yardımcı olursanız çok sevinirim.


KODLARIM

cevap = MsgBox(ad & " in Aile ferdi " & ActiveCell.Offset(0, 0).Value & " i silecek misiniz...", vbInformation + vbYesNo, "Sil")
If cevap = vbYes Then

Dim s As Long
s = ActiveCell.Row

Select Case Val(ListBox1.ListIndex)
Case 0
s = ActiveCell.Row
Range("DO" & s & "DR" & s).Delete Shift:=xlToLeft

Case 1
s = ActiveCell.Row
Range("DS" & s & "DV" & s).Delete Shift:=xlToLeft

Case 2
s = ActiveCell.Row
Range("DW" & s & "DZ" & s).Delete Shift:=xlToLeft

Case 3
s = ActiveCell.Row
Range("EA" & s & ":ED" & s).Delete Shift:=xlToLeft

Case 4
s = ActiveCell.Row
Range("EE" & s & ":EH" & s).Delete Shift:=xlToLeft

Case 5
s = ActiveCell.Row
Range("EI" & s & ":EL" & s).Delete Shift:=xlToLeft
End Select
End If

 

[ahmed_ummu]

Hala çözemedim arkadaşlar. Yardımcı olabilecek varsa sevinirim.

 

[netzone]

Merhaba,
Silinen seçiminiz kadar hücre ekleyerek ters tarafa ötelemeniz sorununuzu çözebilir.

Selection.Delete Shift:=xlToLeft Selection.Insert Shift:=xlToRight

İyi çalışmalar.

 

[ahmed_ummu]

Merhaba,
Silinen seçiminiz kadar hücre ekleyerek ters tarafa ötelemeniz sorununuzu çözebilir.

Selection.Delete Shift:=xlToLeft Selection.Insert Shift:=xlToRight

İyi çalışmalar.

Sayın netzone teşekkürler. Bu eklemeyi EL sütundan sonra yapabilir miyiz. EL sütunundan sonra 4 sütun ekleyecek.

 

[netzone]

Sayın netzone teşekkürler. Bu eklemeyi EL sütundan sonra yapabilir miyiz. EL sütunundan sonra 4 sütun ekleyecek.

Merhaba,
Kod bilgim çok yok ama örnek bir paylaşım yaparsanız, tablonuz üzerinde deneme yaparak sonuca ulaşabilirim.
İyi çalışmalar.

 

[ahmed_ummu]

Merhaba,
Kod bilgim çok yok ama örnek bir paylaşım yaparsanız, tablonuz üzerinde deneme yaparak sonuca ulaşabilirim.
İyi çalışmalar.

Örmek dosyada userform1 den mesela Ayşegül KARABACAK seçilsin. (O kişinin iki aile ferdi kayıtı. Her personelin aile ferdi kayıtlı değil)
Kişiyi seçtikten sonra Form 2 yi açın ve listeden herhangi bir kişiyi seçin ve sil butonuna tıklayın. Seçilen kişiyi siliyor ve aktif satırda silinen kişinin bilgilerinin yerine sağdan 4 hücreyi sola doğru kaydırıyor. Silme işlemi yapılan sütunlar DO ve EL sütunları arasnda. Kaydırmayı yaparken, EL sütunundan sonraki sütunlarıda sola kaydırıyor. Yani EM, EN, EO, EP ......... EL sütundan sorası kayma yapmayacak. Dediğim kişiyi seçip Form2 yi açıp herhangi bir kişiyi silerseniz EM sütunununda ola kaydığını göreceksiniz. Yardımcı olursanız sevinirim. Nerdeyse bir hafta oldu hala çözemedim.

 

[netzone]

Merhaba,

Yaptığım deneme sonucu bu şekilde bir çözüm ürettim umarım işinize yarar. (İlgili satırda silinen 4 hücreyi yine aynı yere bir önceki sütun sonrasına boş olarak ekler)

Yukarıdaki seçim bu şekilde de belirterek aynı sonuca ulaşılabilir görünüyor.
Selection.Insert Shift:=xlToRight Range("DO" & s & ":DR" & s).Insert Shift:=xlToRight

İyi çalışmalar.

Private Sub CommandButton1_Click()
cevap = MsgBox(ad & " in Aile ferdi " & ActiveCell.Offset(0, 0).Value & " i silecek misiniz...", vbInformation + vbYesNo, "Sil")
If cevap = vbYes Then

Dim s As Long
s = ActiveCell.Row
   
  Select Case Val(ListBox1.ListIndex)
  Case 0
   s = ActiveCell.Row
    Range("DO" & s & ":DR" & s).Delete Shift:=xlToLeft
    Range("DN" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

  Case 1
   s = ActiveCell.Row
    Range("DS" & s & ":DV" & s).Delete Shift:=xlToLeft
    Range("DR" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight
   
Case 2
  s = ActiveCell.Row
    Range("DW" & s & ":DZ" & s).Delete Shift:=xlToLeft
    Range("DV" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

Case 3
  s = ActiveCell.Row
    Range("EA" & s & ":ED" & s).Delete Shift:=xlToLeft
    Range("DZ" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

Case 4
s = ActiveCell.Row
    Range("EE" & s & ":EH" & s).Delete Shift:=xlToLeft
    Range("ED" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

Case 5
s = ActiveCell.Row
    Range("EI" & s & ":EL" & s).Delete Shift:=xlToLeft
    Range("EH" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight
  End Select
End If
End Sub

 

[ahmed_ummu]

Merhaba,

Yaptığım deneme sonucu bu şekilde bir çözüm ürettim umarım işinize yarar. (İlgili satırda silinen 4 hücreyi yine aynı yere bir önceki sütun sonrasına boş olarak ekler)

Yukarıdaki seçim bu şekilde de belirterek aynı sonuca ulaşılabilir görünüyor.
Selection.Insert Shift:=xlToRight Range("DO" & s & ":DR" & s).Insert Shift:=xlToRight

İyi çalışmalar.

Private Sub CommandButton1_Click()
cevap = MsgBox(ad & " in Aile ferdi " & ActiveCell.Offset(0, 0).Value & " i silecek misiniz...", vbInformation + vbYesNo, "Sil")
If cevap = vbYes Then

Dim s As Long
s = ActiveCell.Row
  
  Select Case Val(ListBox1.ListIndex)
  Case 0
   s = ActiveCell.Row
    Range("DO" & s & ":DR" & s).Delete Shift:=xlToLeft
    Range("DN" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

  Case 1
   s = ActiveCell.Row
    Range("DS" & s & ":DV" & s).Delete Shift:=xlToLeft
    Range("DR" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight
  
Case 2
  s = ActiveCell.Row
    Range("DW" & s & ":DZ" & s).Delete Shift:=xlToLeft
    Range("DV" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

Case 3
  s = ActiveCell.Row
    Range("EA" & s & ":ED" & s).Delete Shift:=xlToLeft
    Range("DZ" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

Case 4
s = ActiveCell.Row
    Range("EE" & s & ":EH" & s).Delete Shift:=xlToLeft
    Range("ED" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight

Case 5
s = ActiveCell.Row
    Range("EI" & s & ":EL" & s).Delete Shift:=xlToLeft
    Range("EH" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight
  End Select
End If
End Sub

Çok teşekkürler sayın netzone End Select in dışına aşağıdaki satırı ekleyince düzeldi.

Range("EH" & s).Offset(0, 1).Resize(1, 4).Insert Shift:=xlToRight