Sütun Boşluk Doldurma

[iplikci_80]

A sütunu birleştirilmiş hücrelerden oluşmaktadır ve 507 satıra kadar devam etmektedir, bu daha fazlada olabilir. Burada yapmak istediğim şey A sütunundaki boşlukları aşağıdaki rakamlar ile doldurmak. Yani boşluklara bir alttaki değeri getirmek istiyorum. Örnekte 1,2,3 gidiyor boşluk var boş olan satırlar silinmeden 1,2,3,5,6,7,9,11,13 ..... şeklinde boşlukların doldurulması hususunda yardımlarınızı rica ediyorum.

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
s = Cells(Rows.Count, "A").End(3).Row
With Range("A7:A" & s)
    dz = .Value
    .Value = ""
End With
x = 7
For a = LBound(dz) To UBound(dz)
    If dz(a, 1) <> "" Then
        Cells(x, "A") = dz(a, 1)
        x = x + 2
    End If
Next
End Sub

 

[iplikci_80]

ÖmerBey ilginize teşekkür ederim. Bu kodu A sütunundan herhangibir hücre boşaldığında çalışır duruma getirebilir miyiz lütfen. Her seferinde F5 yapmam gerekiyor.

 

[iplikci_80]

Yardımlarınızı rica ediyorum.

 

[Korhan Ayhan]

Sayfanızın kod bölümüne uygulayıp deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Veri As Variant, Alan As Range, Son As Long, X As Long, Say As Long
    
    On Error GoTo Son
    
    If Intersect(Target, Range("A7:A" & Rows.Count)) Is Nothing Then Exit Sub
    
    Application.EnableEvents = False

    For Each Alan In Intersect(Target, Range("A7:A" & Rows.Count))
        If Alan.Value = Empty Then
            Son = Cells(Rows.Count, 1).End(3).Row + 1
            Veri = Range("A7:A" & Son).Value
            Range("A7:A" & Son).ClearContents
            ReDim Liste(1 To Son, 1 To 1)
            Say = 1
            For X = LBound(Veri, 1) To UBound(Veri, 1)
                If Veri(X, 1) <> "" Then
                    Liste(Say, 1) = Veri(X, 1)
                    Say = Say + 2
                End If
            Next
            Exit For
        End If
    Next
    
   If Say > 0 Then Range("A7").Resize(Say) = Liste

Son: Application.EnableEvents = True
End Sub

 

[iplikci_80]

Çok teşekkür ederim.