Soru İstenilen satırları sil yukarı kaydır.

[ADER_34]

Merhaba arkadaşlar ekteki dosyada turuncu satırları makro ile silmek istiyorum,Turuncu renk örnektir her EVRAK ID dosyası ayrı açılır ve hepsinde X yazan kısımlarda veri var onlar bana gereksiz olduğu için verileri ben X yaptım aslında orda bana gereksiz veriler var ve fazla yer kaplıyor, bu satırlar X ile belirttim hepsinin silinmesini ve arada ki boş satırların yukarı taşınmasını istiyorum mümkümse teşekkürler kolay gelsin..
ÖRNEK dosya: https://s2.dosya.tc/server29/znult7/EVRAK_SORGU_3.xlsx.html

 

[Muzaffer Ali]

Merhaba.
Örnek dosyanızda Turuncu renkli ve x yazan satırların silinmesini istiyorsunuz ama bize asıl lazım olan bilgi orijinal dosyanızda hangi satırların silinmesini istediğinizdir.

Orijinal dosyanızda hangi kolonda hangi değer varsa silinmesi gerekiyor?

 

[ADER_34]

Merhaba.
Örnek dosyanızda Turuncu renkli ve x yazan satırların silinmesini istiyorsunuz ama bize asıl lazım olan bilgi orijinal dosyanızda hangi satırların silinmesini istediğinizdir.

Orijinal dosyanızda hangi kolonda hangi değer varsa silinmesi gerekiyor?

Merhaba Muzaffer Bey dosyadaki satırlar veri tabanından alınıyor ve hepsi aynı formatta,renklendirme yi örnek alan olarak yaptım aslında renk yok,
ve X yazan satırlar daima dolu oluyor,

Merhaba.
Örnek dosyanızda Turuncu renkli ve x yazan satırların silinmesini istiyorsunuz ama bize asıl lazım olan bilgi orijinal dosyanızda hangi satırların silinmesini istediğinizdir.

Orijinal dosyanızda hangi kolonda hangi değer varsa silinmesi gerekiyor?

Merhaba Muzaffer Bey turuncu renk benim renklendirmem,silinecek alan belli olsun diye aslında renkle işim yok, verileri sabit veri tabanından kopyalıyorum yani "X" satırlar yeri veri hücreleri noktasına kadar aynı yerde olyor, fakat aynı sayfaya alt alta kopyla yapıştır ile veri alıyorum yani X olan satırlar bana lazım değil. özetle şunuda diyebilirim, önce "A" sütünunda EVRAK ID bul, sonra SAHİP satırı altında kalan satırları TALEP satırının bir üst verisine kadar sil, sonra ara boşuğu yukarı çek,sonra SIRA no altına son satıra kadar in bir sonra ki dolu satırları EVRAK ID kısmına kadar sil, bu döngüyü alt satılara kadar uygula teşekkürler..

 

[Muzaffer Ali]

Bazı boş hücrelere "Her sıralı satırda böyle boşluk var bu altta ki 3 satırı istemiyorum" beyaz font ile yazmışsınız görünmüyor. Bunu anlamak biraz zaman aldı.

Aşağıdaki kodu deneyiniz.

Sub Test()

    Dim Bak As Long
    Dim BakBos As Integer
    Dim BakBos_ As Integer
    
    For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(Bak, "A") = "Sahip" Then
            For BakBos = Bak + 1 To Cells(Rows.Count, "A").End(xlUp).Row
                If Cells(BakBos, "A") = "" And BakBos - Bak > 1 Then
                    Rows(Bak + 1 & ":" & BakBos - 1).Delete
                    Exit For
                ElseIf Cells(BakBos, "A") = "Sahip" Or Cells(BakBos, "A") = "Sıra" Then
                    Exit For
                End If
            Next
        End If
    Next

    For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(Bak, "A") = "Sıra" Then
            For BakBos = Bak + 1 To Cells(Rows.Count, "A").End(xlUp).Row
                If Cells(BakBos, "A") = "" Then
                    For BakBos_ = BakBos + 1 To Cells(Rows.Count, "A").End(xlUp).Row + 1
                        If Cells(BakBos_, "A") = "" And BakBos_ - BakBos > 1 Then
                            Rows(BakBos + 1 & ":" & BakBos_ - 1).Delete
                            Exit For
                        ElseIf Cells(BakBos_, "A") = "Talep Listesi" Or Cells(BakBos_, "A") = "Evrak ID" Then
                            Exit For
                        End If
                    Next
                    Exit For
                End If
            Next
        End If
    Next
End Sub

 

[alicimri]

Yedek alıp deneyin.

Sub sil()
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If InStr("21SıraTalep ListesiSahipEvrak ID", Cells(i, 1)) = 0 Then
Rows(i).Delete Shift:=xlUp
End If
Next
End Sub

 

[alicimri]

Eğer turuncu zeminli olamayan veri girilmemiş satırların kalmasını istiyorsanız aşağıdaki deneyin.

Sub sil()
For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
If InStr("SıraTalep ListesiSahipEvrak ID", Cells(i, 1)) = 0 And Not IsNumeric(Cells(i, 1)) Then
Rows(i).Delete Shift:=xlUp
End If
Next
End Sub

 

[veyselemre]

Sub test()
    Dim son&, i
    son = Cells(Rows.Count, 1).End(3).Row
    Range("H:H").ClearContents
    For i = son To 3 Step -1
        If Cells(i, 1).Value = "Evrak ID" Or _
           Cells(i, 1).Value = "Talep Listesi" Then Cells(i - 1, "H").Resize(3).Value = "-"
        If Cells(i, 7).Value <> "" Then Cells(i, "H").Value = "-"
    Next i
    With Range("H2:H" & son)
        If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .ClearContents
    End With
End Sub

 

[ADER_34]

Bazı boş hücrelere "Her sıralı satırda böyle boşluk var bu altta ki 3 satırı istemiyorum" beyaz font ile yazmışsınız görünmüyor. Bunu anlamak biraz zaman aldı.

Aşağıdaki kodu deneyiniz.

Sub Test()

    Dim Bak As Long
    Dim BakBos As Integer
    Dim BakBos_ As Integer
   
    For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(Bak, "A") = "Sahip" Then
            For BakBos = Bak + 1 To Cells(Rows.Count, "A").End(xlUp).Row
                If Cells(BakBos, "A") = "" And BakBos - Bak > 1 Then
                    Rows(Bak + 1 & ":" & BakBos - 1).Delete
                    Exit For
                ElseIf Cells(BakBos, "A") = "Sahip" Or Cells(BakBos, "A") = "Sıra" Then
                    Exit For
                End If
            Next
        End If
    Next

    For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(Bak, "A") = "Sıra" Then
            For BakBos = Bak + 1 To Cells(Rows.Count, "A").End(xlUp).Row
                If Cells(BakBos, "A") = "" Then
                    For BakBos_ = BakBos + 1 To Cells(Rows.Count, "A").End(xlUp).Row + 1
                        If Cells(BakBos_, "A") = "" And BakBos_ - BakBos > 1 Then
                            Rows(BakBos + 1 & ":" & BakBos_ - 1).Delete
                            Exit For
                        ElseIf Cells(BakBos_, "A") = "Talep Listesi" Or Cells(BakBos_, "A") = "Evrak ID" Then
                            Exit For
                        End If
                    Next
                    Exit For
                End If
            Next
        End If
    Next
End Sub

Muzaffer hocam kodlar istediğimi yapıyor fakat 5 defa arka arkaya çalıştırınca yapıyor rica etsem tek seferde yapmak için hangi kodu eklemeliyim bakabilirmisiniz? Teşekkürler.

 

[Muzaffer Ali]

6 numaralı mesajdaki kodu deneyiniz.
Benim kodlar gereksiz uzun oldu.

 

[ADER_34]

6 numaralı mesajdaki kodu deneyiniz.
Benim kodlar gereksiz uzun oldu.

Muzaffer hocam yinede çok teşekkür ederim size 7 numarada Veyselemre hocamın kodları sorunsuz çalışıyor.Hepinizden Allah razı olsun sorunum çözülmüştür..

 

[ADER_34]

Sub test()
    Dim son&, i
    son = Cells(Rows.Count, 1).End(3).Row
    Range("H:H").ClearContents
    For i = son To 3 Step -1
        If Cells(i, 1).Value = "Evrak ID" Or _
           Cells(i, 1).Value = "Talep Listesi" Then Cells(i - 1, "H").Resize(3).Value = "-"
        If Cells(i, 7).Value <> "" Then Cells(i, "H").Value = "-"
    Next i
    With Range("H2:H" & son)
        If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .ClearContents
    End With
End Sub

VeyselEmre hocam bundan 10 Yıl önce karmaşık ve 10 15 dakikamı alan bir excel sayfamı, 1 saniye gibi kısa bir sürede işlem yapan kodlar yazarak beni heyacanlı bir makro seven bir kullanıcı yapmıştınız,yine sizden kod almak tevafuk oldu ,Allah sizdende Razı olsun, Hepiniz harikasınız, kolay gelsin.teşekkürler. iyi çalışmalar..