Çözüldü verileri teke düşürme

[mustafa070707]

dosya ekledim yardımlarınızı bekliyorum teşekkürler.

 

[mustafa070707]

Dosyanın içeriğine yazdım burada uzun olmasın diye düşündüm bi art niyetim yoktu

 

[tukayf]

Dim sonSatir As Long
sonSatir = syf2.Cells(syf2.Rows.Count, "E").End(xlUp).Row
Dim i As Long
For i = sonSatir To 2 Step -1
If WorksheetFunction.CountA(syf2.Rows(i)) = 0 Then
syf2.Rows(i).Delete
End If
Next i

kodun altına ekleyip deneyebilir misiniz. sayfaya ve kodlara bakıp anlayabildiğim bu. Ancak hem sayfa1 hem sayfa2 ismi "tek" olarak tanımlanmış bu kodun çalışmaması lazım.

Konuda üslup sorunu var ancak soruyu yazan değil de başka bir arkadaş yol açmış sanki bu soruna.

 

[mustafa070707]

kodun altına ekleyip deneyebilir misiniz. sayfaya ve kodlara bakıp anlayabildiğim bu. Ancak hem sayfa1 hem sayfa2 ismi "tek" olarak tanımlanmış bu kodun çalışmaması lazım.

Konuda üslup sorunu var ancak soruyu yazan değil de başka bir arkadaş yol açmış sanki bu soruna.

benim paylaştığım kod çalışıyor fakat sizin dediğinizi ekledim herhangi bir değişiklik olmadı

 

[tukayf]

benim paylaştığım kod çalışıyor fakat sizin dediğinizi ekledim herhangi bir değişiklik olmadı

hocam ben sayfa2 ye aktaracaksınız diye okudum kodda. O nedenle sayfa2 için düzenlemiştim.
Aynı sayfa için ise

Dim sonSatir As Long
sonSatir = syf1.Cells(syf1.Rows.Count, "E").End(xlUp).Row
Dim i As Long
For i = sonSatir To 2 Step -1
If syf1.Cells(i, 5).Value = "" Then
syf1.Rows(i).Delete
End If
Next i

bu kodu ekler misiniz.

 

[mustafa070707]

hocam ben sayfa2 ye aktaracaksınız diye okudum kodda. O nedenle sayfa2 için düzenlemiştim.
Aynı sayfa için ise

bu kodu ekler misiniz.

çok teşekkür ederim elinize sağlık

 

[Özcan ÖZBEK]

benim paylaştığım kod çalışıyor fakat sizin dediğinizi ekledim herhangi bir değişiklik olmadı

Private Sub CommandButton1_Click()
'teke dusurme ve sıralama

Dim syf1 As Worksheet
Dim syf2 As Worksheet
Set syf1 = Worksheets("tek")
Set syf2 = Worksheets("tek")
Application.ScreenUpdating = False
syf1.Range("A1" & syf1.Cells(Rows.Count, "A").End(xlUp).Row).Copy syf2.Range("E2")
syf2.Range("E:H").RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
Application.ScreenUpdating = True
Columns("e:h").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub

 

[tukayf]

çok teşekkür ederim elinize sağlık

Dim sonSatir As Long
sonSatir = syf1.Cells(syf1.Rows.Count, "E").End(xlUp).Row
Dim i As Long
For i = sonSatir To 2 Step -1
If syf1.Cells(i, 5).Value = "" Then
syf1.Range(syf1.Cells(i, 5), syf1.Cells(i, 8)).Delete
End If
Next i

bunu kodu kullanın lütfen. bir kaç deneme yapar mısınız.

 

[Patron]

Deneyiniz.
HTML:

İçeriği görebilmek için Giriş yap ya da Üye ol.

 

[mustafa070707]

bunu kodu kullanın lütfen. bir kaç deneme yapar mısınız.

Gayet iyi çalıştı ilgilenen herkesin eline sağlık