boş hücreleri kaydırma

[mustafa7456]

bir mahkemede açık olan dosyaların listesi var. a1 den j2000 e kadar soldan sağa 10 lu gruplar şeklinde. dosyalar karara çıktıkça veya kapandıkça dosya numarasını bu listeden bulup siliyoruz. silince arada boşluk oluşuyor. sayması veya sıralaması çok zor oluyor. bizim istediğimiz satırdaki 10 lu grup bozulmadan hem sola hemde yukarı kaydırılabilirmi. örnek:

1 2 3 4 5 6 7 8 9 10
11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30

mesela aradan bir kaç silinince şöyle olsun

1 2 4 5 6 7 8 9 10 11
12 14 15 16 17 19 21 22 26 27
28 29 30

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Bos_Hucre_Sil()
    
    Dim i As Long
    
    Application.ScreenUpdating = False

    For i = 1 To [A:J].Find("*", , , , xlByRows, xlPrevious).Row
        If WorksheetFunction.CountA(Cells(i, "A").Resize(1, 10)) <> 10 Then
            Cells(i, "A").Resize(1, _
                10).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[mustafa7456]

bu formül hücreyi silip sola yanaştırıyor. benim istediğim hem sola yanaşacak hemde satırlar yine 10 lu grup şeklinde olacak. yani her satırda mutlaka 10 veri olması lazım. çünkü listelerimiz çok büyük. ve yönetmelik gereği bu şekilde arşivlenmesi gerekiyor.

 

[YUSUF44]

Bunun için şöyle bir öneride bulunayım :

Ayrıca bir sayfada tüm listenin olsun. Bir satırda dosya numarası ve karşısında açık ya da kapalı olduğu belirtilsin. Sonra makro ile bu listeye bakarak açık olanlar sonuç tablosuna istediğiniz şekilde aktarılsın.
Bunun için belirttiğim gibi örnek bir dosya hazırlayıp asıl tablonuzdaki yapıyı gösterirseniz kolay çözüm bulunur.

 

[Asri]

Alternatif;

Sayfanın kod bölümüne yapıştırıp, silinecek hücreyi çift tıklayın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    If Intersect(Target, Range("A:J")) Is Nothing Then Exit Sub
    satir = Target.Row
    sutun = Target.Column
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Selection.Delete Shift:=xlToLeft
    For i = satir To sonsatir
      Range("A" & i + 1).Select
      Selection.Cut Destination:=Range("J" & i)
      Range("A" & i + 1).Select
      Selection.Delete Shift:=xlToLeft
    Next i
End Sub

 

[Ömer]

Umarım doğru anlamışımdır.

Sub Bos_Hucre_Duzenle()
    
    Dim hcr As Range, a As Integer, dizi(), i As Integer, sat As Integer, sut As Byte
    
    Application.ScreenUpdating = False

    For Each hcr In Range("A1:J200").SpecialCells(xlCellTypeConstants, 23)
        ReDim Preserve dizi(a)
        dizi(a) = hcr
        a = a + 1
    Next
    
    Range("A1:J200").ClearContents
    
    sat = 1: sut = 1
    For i = 0 To a - 1
        Cells(sat, sut) = dizi(i)
        sut = sut + 1
        If i <> 0 And i Mod 10 = 0 Then sat = sat + 1
        If i Mod 10 = 0 Then sut = 1
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[mustafa7456]

ömer bey. Teşekkür ederim. mükemmel oldu. ellerinize sağlık

 

[mustafa7456]

asri beyin yaptığı da oldu fakat, onu diğer mahkemede çalışan arkadaşlara anlatmak biraz sıkıntılı, veya yanlışlıkla çift tıklanınca silinir. resmi işte kullanılacağı için risk li biraz. yinede zaman ayırdığınız için sağolun.