Şarta Bağlı Satır Gizleme

[ertanemre]

Merhaba,

Yalnızca A1-E500 aralığının tablo olarak kullanıldığı bir exceldeki veriler günün sonunda value yapıştırılıyor, hücrelerde hiç formül kalmıyor.
Fakat bu tabloyu final hale getirmeden önce bu 500 satır içinde yalnızca 200 satırın B-C-D-E sütunlarındaki hücreler dolu olabiliyor. Ben geriye kalan satırları otomatik gizlemek istiyorum. Burada A sütununun dolu olup olmadığı dikkate alınmamalı.
Bu işlem sonrası dolu olan tüm satırlar alt alta geleceği için aralarına düzenli olarak birer boş satır eklemek istiyorum.
Makro buton ya da tuş atama şeklinde yapılabilir, mümkün müdür bilemedim ama değerli desteklerinizi rica edeceğim

Örnek bir görüntü ekliyorum, ilk hali ile makro çalıştırıldıktan sonra ulaşmak istediğim halini gösterdim.

Teşekkürler şimdiden.

Foto

 

[Necdet]

Merhaba,

Fotoğraf değil örnek dosyanızı paylaşın ki ilgilenen arkadaşlar üzerinde çalışsın,.

 

[ertanemre]

Direkt tabloyu ekleyecek bir buton bulamadım, forumda yeniyim. Aşağıdaki gibi bir linke yükledim.


Excel örnek tablo

 

[alicimri]

Aşağıdaki kodu deneyin.

Sub yenile()
Say = Cells(Rows.Count, 1).End(3).Row
Range("A2:E" & Say).Copy
Range("A2").PasteSpecial Paste:=xlPasteValues
 Range("A1:E" & Say).AutoFilter Field:=1, Criteria1:="="
    Rows("2:" & Say + 1).Delete Shift:=xlUp
Range("A1").AutoFilter
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
   Cells(i, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Next
End Sub

 

[ertanemre]

Aşağıdaki kodu deneyin.

Sub yenile()
Say = Cells(Rows.Count, 1).End(3).Row
Range("A2:E" & Say).Copy
Range("A2").PasteSpecial Paste:=xlPasteValues
Range("A1:E" & Say).AutoFilter Field:=1, Criteria1:="="
    Rows("2:" & Say + 1).Delete Shift:=xlUp
Range("A1").AutoFilter
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
   Cells(i, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Next
End Sub

Yanlış bir şey yapmadıysam eğer; B, C, D, E sütunlarındaki hücreleri boş olan "Teminat Bedeli" ve "Yan Hizmet" satırları gizlenmiyor.

 

[alicimri]

Yanlış anlamışım örnek dosya ekte, kod aşağıda

Ornek_tablo.xlsm dosyasını indir - download

Ornek_tablo.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

Sub yenile()
Range("A1:E" & Cells(Rows.Count, 1).End(3).Row).Copy
     Range("A1").PasteSpecial Paste:=xlPasteValues
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If Cells(i, 2) = "" And Cells(i, 3) = "" And Cells(i, 4) = "" And Cells(i, 5) = "" Then
Rows(i).Delete Shift:=xlUp
End If
Next
For e = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
Cells(e, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Next
End Sub

 

[alicimri]

Formülleri Değere çevirmeyi unutmuşum, #6 nolu mesajdaki kodları yeniledim.

 

[ertanemre]

Hızlı dönüşünüz için teşekkür ediyorum.
Güncel kodu çalıştırdım fakat bu şekilde gizlenmesini istediğim satırlar siliniyor. Ben onların gizli şekilde kalmasını istiyorum çünkü A sütununda yer alan açıklamalı hücrelere sürekli ihtiyacım olacak.

Ayrıca benim ilk mesajımda yanlış aktarmam oldu, o sebeple siz formülü değer olarak yapıştırttınız.
B, C, D, E kolonunda formül olan hücreler olduğu gibi kalacak şekilde yapabilir miyiz?

 

[ertanemre]

Formülleri Değere çevirmeyi unutmuşum, #6 nolu mesajdaki kodları yeniledim.

Son mesajıma ek yapayım.
Bir önceki mesajınızda yaptığınız güncelleme öncesindeki kod (paylaştığınız excelde yer alan) istediğim gibi formülleri mevcut hali ile tutuyor sanıyorum.
Sadece boş olan ilgili satırları silmek yerine gizleyebilirsek sanırım işim çözülüyor.

 

[alicimri]

Deneyin Bu sefer olmuştur herhalde

Ornek_tablo.xlsm dosyasını indir - download

Ornek_tablo.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

Sub yenile()
Rng = Range("A1:E" & Cells(Rows.Count, 1).End(3).Row)
     Range("A1:E" & Cells(Rows.Count, 1).End(3).Row).Value = Rng
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If Cells(i, 2) = "" And Cells(i, 3) = "" And Cells(i, 4) = "" And Cells(i, 5) = "" And Cells(i, 1) = "" Then
Rows(i).Delete Shift:=xlUp
ElseIf Cells(i, 2) = "" And Cells(i, 3) = "" And Cells(i, 4) = "" And Cells(i, 5) = "" Then
    Rows(i).EntireRow.Hidden = True
End If
Next
For e = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If Cells(e, 2) <> "" Or Cells(e, 3) <> "" Or Cells(e, 4) <> "" Or Cells(e, 5) <> "" Then
Cells(e, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub
Sub Goster()
Rows("1:" & Cells(Rows.Count, 1).End(3).Row).EntireRow.Hidden = Talse
End Sub

 

[alicimri]

Rng = Range("A1:E" & Cells(Rows.Count, 1).End(3).Row)
     Range("A1:E" & Cells(Rows.Count, 1).End(3).Row).Value = Rng

Bu satırları silin.

 

[ertanemre]

Deneyin Bu sefer olmuştur herhalde

Ornek_tablo.xlsm dosyasını indir - download

Ornek_tablo.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

Sub yenile()
Rng = Range("A1:E" & Cells(Rows.Count, 1).End(3).Row)
     Range("A1:E" & Cells(Rows.Count, 1).End(3).Row).Value = Rng
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If Cells(i, 2) = "" And Cells(i, 3) = "" And Cells(i, 4) = "" And Cells(i, 5) = "" And Cells(i, 1) = "" Then
Rows(i).Delete Shift:=xlUp
ElseIf Cells(i, 2) = "" And Cells(i, 3) = "" And Cells(i, 4) = "" And Cells(i, 5) = "" Then
    Rows(i).EntireRow.Hidden = True
End If
Next
For e = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If Cells(e, 2) <> "" Or Cells(e, 3) <> "" Or Cells(e, 4) <> "" Or Cells(e, 5) <> "" Then
Cells(e, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub
Sub Goster()
Rows("1:" & Cells(Rows.Count, 1).End(3).Row).EntireRow.Hidden = Talse
End Sub

Oldu hocam, çoook teşekkür ediyorum, emeğinize sağlık.