Sıfır Değerlerini Eklemeden Listele - Microsoft Excel

Worksheet_SelectionChange olayını kullanarak bir eleme işlemi yapacağız. Değeri sıfıra eşit olmayanları listeleteceğiz ama bu işlem yanlızca A1 – A1000 hücreleri arasında olacak. Değerler eklendikçe B sütununda da verilen kriterlere göre listeleme yapılacak.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [A1:A1000]) Is Nothing Then Exit Sub
    SifirRakaminiEklemedenListele
End Sub

Sub SifirRakaminiEklemedenListele()
    Dim i, sds, sayac As Double
    
    sayac = 1
    sds = Range("A1048576").End(xlUp).Row

    Columns("B").ClearContents
    
    For i = 1 To sds
        If (Range("A" & i) <> 0) Then
            Range("B" & sayac) = Range("A" & i)
            sayac = sayac + 1
        End If
    Next
End Sub

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    '--------------------------------------------------
    'Bu tarza benzer bir kodla çok karşılaşmış olabilirsiniz.
    'Bunun manası şu: En baştan kontrol yap, eğer şart
    'sağlanmıyorsa yordamdan çık.
    '
    'Buradaki kod diyor ki şimdi benim Target dinamik değerim
    'senin bana vermiş olduğun [A1:A1000] ile kesişiyorsa,
    'yani kullanıcı o hücrelerden birisini seçmişse çalışsın,
    'seçmemişse direkt olarak çıksın gitsin.
    '--------------------------------------------------
    If Intersect(Target, [A1:A1000]) Is Nothing Then Exit Sub
    
    '--------------------------------------------------
    'Eğer yukarıdaki If koşuluna takılmadıysa bu koda
    'ulaşmış olacağız, istenilen makroyu çalıştırıyoruz.
    '--------------------------------------------------
    SifirRakaminiEklemedenListele
End Sub

'--------------------------------------------------
'Seçerek ekleme işlemini Sub yordam olarak
'hazırladım, aslında kodları doğrudan
'Worksheet_SelectionChange olayına
'yazabilirdik ama ben karışıklığı
'azalttığından ve daha kullanışlı
'olabileceğinden dolayı bu şekilde
'hazırladım.
'--------------------------------------------------
Sub SifirRakaminiEklemedenListele()
    Dim i, sds, sayac As Double
    
    '--------------------------------------------------
    'Değişkenlere değer atıyoruz.
    '--------------------------------------------------
    sayac = 1
    sds = Range("A1048576").End(xlUp).Row
    
    '--------------------------------------------------
    'B sütunundaki içerikleri temizledik.
    '--------------------------------------------------
    Columns("B").ClearContents
    
    '--------------------------------------------------
    'Döngü ile kontrol yapıyoruz.
    '--------------------------------------------------
    For i = 1 To sds
        
        '--------------------------------------------------
        'Eğer seçilen satırdaki değer sıfır değilse işlem yap.
        '--------------------------------------------------
        If (Range("A" & i) <> 0) Then
            
            '--------------------------------------------------
            'B sütununa ekleme işlemi yap.
            '--------------------------------------------------
            Range("B" & sayac) = Range("A" & i)
            sayac = sayac + 1
        End If
    Next
End Sub