Belli sütunların son dolu hücrelerini kontrol et, eğer sıfır ise sütun sil

[dgdizayn]

Merhabalar,

Ekte ve görselde görüleceği üzerine bir fiyat tablosu var. Bu fiyat tablosunda C,F,I,L,O,R sütunlarında fiyat toplamları yazıyor.

Talebim; C,F,I,L,O,R sütunlarının en son dolu hücresini kontrol et, örneğin C sütunundaki en son dolu hücre hücre 0 rakamını içeriyorsa bir solundaki iki sütunu sil. Yani ABC sütunu sil. Başka örnek verecek olursak L sütunun en son dolu hücresi 0 ise JKL sütununu sil. Böyle birşey yazdırabilir miyiz acaba.

Teşekkürler.

 

[askm]

Aşağıdaki kodları deneyiniz.

Sub askm()
Dim sonsat As Long
Dim sonsut As Long

sonsat = Range("A" & Rows.Count).End(3).Row + 1
sonsut = Cells(2, Columns.Count).End(xlToLeft).Column
For y = sonsut To 1 Step -3
    If Cells(sonsat, y) = 0 Then
        For t = 0 To 2
            Columns(y - t).Delete
        Next t
    End If
Next y
End Sub

 

[dgdizayn]

Aşağıdaki kodları deneyiniz.

Sub askm()
Dim sonsat As Long
Dim sonsut As Long

sonsat = Range("A" & Rows.Count).End(3).Row + 1
sonsut = Cells(2, Columns.Count).End(xlToLeft).Column
For y = sonsut To 1 Step -3
    If Cells(sonsat, y) = 0 Then
        For t = 0 To 2
            Columns(y - t).Delete
        Next t
    End If
Next y
End Sub

Hocam selamlar,

Emeğinize sağlık teşekkür ederim fakat sanırım ben eksik anlattığım için istediğim gibi olmadı. Dosyanın tamamı ekteki gibidir. Solunda kalan tanımlar stoklar 0 olmayan ne varsa siliyor. Bunun için bir düzenleme yapabilir miyiz. Şimdiden çok teşekkür ederim.

 

[dgdizayn]

Hocam selamlar tekrardan,

Sol tarafı bir şekilde kurcalayarak bir şekilde hallettim ama sağdakilerde gidiyor. Nihai dosya ekteki gibidir, bilginize.

Teşekkürler.

 

[dgdizayn]

Askm hocam,

Emeklerin için teşekkür ederim. Biraz yabancı forumlardan araştırıp üzerine de kendi yorumumu katarak güzel bir kod çalıştı. Kod çalışma mantığı şu şekilde; İstediğin sütunun son dolu hücresini kontrol et ve bu değer 0 ise istediğin sütunları sil. Belki başkalarına da faydalı olur.

Sub sifirsakolonlarisil()
Dim i As Long, LR As Long
 
LR = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
 
For i = Range("AM3").Column To Range("AM3").Column Step -1 'En son dolu sütunu kontrol et
    If Application.Sum(Cells(1, i).Resize(LR, 1)) = 0 Then Columns("AK:AM").Delete Shift:=xlToLeft 'Sonuç 0 ise istediğin sütunları sil
Next i
For i = Range("AD3").Column To Range("AD3").Column Step -1 'En son dolu sütunu kontrol et
    If Application.Sum(Cells(1, i).Resize(LR, 1)) = 0 Then Columns("AB:AD").Delete Shift:=xlToLeft 'Sonuç 0 ise istediğin sütunları sil
Next i
End Sub

 

[Korhan Ayhan]

Alternatif,

İlk mesajınıza göre kod yazılmıştır.

Option Explicit

Sub Sifir_Olan_Sutunlari_Sil()
    Dim My_Range As Range, Alan As Range
    
    For Each My_Range In Range("C2:C2,F2:F2,I2:I2,L2:L2,O2:O2,R2:R2")
        If Cells(Rows.Count, My_Range.Column).End(3) = 0 Then
            If Alan Is Nothing Then
                Set Alan = My_Range.Offset(, -2).Resize(1, 3)
            Else
                Set Alan = Union(Alan, My_Range.Offset(, -2).Resize(1, 3))
            End If
        End If
    Next

    If Not Alan Is Nothing Then
        Alan.EntireColumn.Delete xlLeft
        MsgBox "Toplamı sıfır olan sütunlar silindi!", vbInformation
    Else
        MsgBox "Toplamı sıfır olan sütun bulunamadı!", vbCritical
    End If
End Sub