eşleşenleri bul ilgili satırları sil

[ismailozkan4224]

selam. değerli arkadaşlar ilgili dosyamda TicimaxUrunler ve 1 nolu diye iki sayfam var. 1 nolu sayfada "A" sütununda yazılan ve daha sonra yazılabilecek ilave ürünleri TicimaxUrunler sayfasında " E" sütunda bulup o satırları tamamen silmesini istiyorum. 1 nolu sayfadaki numaralar ve TicimaxUrunler sayfasının "E" sütundaki barkod numaraları benzersizdir

 

[hamitcan]

Sub Sil()
    For i = Sheets("1").[a65536].End(3).Row To 2 Step -1
        If WorksheetFunction.CountIf(Sheets("TicimaxUrunler").[e:e], Sheets("1").Cells(i, 1)) >= 1 Then
            Sheets("TicimaxUrunler").Rows(i).Delete
        End If
    Next
    MsgBox "İşlem Tamamlandı"
End Sub

 

[ismailozkan4224]

sayın hamitcan cevabınız için teşekkür ederim. ancak istenen satırların tamamını silmiyor. bir kısmını siliyor. bir kısmını silmiyor.

 

[ismailozkan4224]

aralardan ürün yazıldığında silmiyor. örnek 5. satırdaki ürün,15. satırdaki ürün,25. satırdaki ürünlerin barkodunu girdiğinde silmiyor

 

[ismailozkan4224]

örnek dosyayı güncelledim. buradan yardım edebilirseniz sevinirim.

 

[hamitcan]

Bir de bu şekilde deneyin.

Sub Sil()
    For i = 2 To Sheets("TicimaxUrunler").[e65536].End(3).Row
        Sheets("TicimaxUrunler").Cells(i, "e") = Val(Sheets("TicimaxUrunler").Cells(i, "e"))
    Next
   
    For i = Sheets("1").[a65536].End(3).Row To 2 Step -1
            If WorksheetFunction.CountIf(Sheets("1").[a:a], Sheets("TicimaxUrunler").Cells(i, "e")) > 0 Then
            Sheets("TicimaxUrunler").Rows(i).Delete
        End If
    Next
    MsgBox "İşlem Tamamlandı"
End Sub

 

[ismailozkan4224]

Sub Sil() For i = 2 To Sheets("TicimaxUrunler").[e65536].End(3).Row Sheets("TicimaxUrunler").Cells(i, "e") = Val(Sheets("TicimaxUrunler").Cells(i, "e")) Next For i = Sheets("1").[a65536].End(3).Row To 2 Step -1 If WorksheetFunction.CountIf(Sheets("1").[a:a], Sheets("TicimaxUrunler").Cells(i, "e")) > 0 Then Sheets("TicimaxUrunler").Rows(i).Delete End If Next MsgBox "İşlem Tamamlandı" End Sub

hamit bey olmuyor. aralarda olduğu zaman silmiyor. en üstte ve arka arkaya ise siliyor. ancak arlarda boşluk varsa silmiyor.

 

[hamitcan]

1 sayfasındaki verileri Eğersay formülü ile saydırdım Sıfır(0) çıktı. Veriler diğer sayfadan silinmiş görünüyor. Farklı bir şey mi istiyor sunuz ?

 

[ismailozkan4224]

hamit bey ben de denedim ilk 7 tanesini siliyor. sonra makroyu tekrarlıyorum 9 oluyor. sonra 10 oluyor. 10 dan fazlasını silmedi. lütfen ekli dosyadan çalıştırırmısınız. 1 sayfada sarı sütun eğersay formüllüdür. 146703 barkodu dahil sonrasını silmedi

 

[Ziynettin]

Alternatif,

Sub test()
Dim a(), b(), c(), d As Object
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim i As Long, say As Long, y As Byte
Set s1 = Sheets("1")
Set s2 = Sheets("TicimaxUrunler")
Set d = CreateObject("scripting.dictionary")

    a = s1.Range("A2:A" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    For i = 1 To UBound(a)
        krt = Application.Trim(a(i, 1))
        d(krt) = d(krt) + 1
    Next i
    
    b = s2.Range("A2:BG" & s2.Cells(Rows.Count, 1).End(3).Row).Value
    ReDim c(1 To UBound(b), 1 To UBound(b, 2))
    For i = 1 To UBound(b)
        krt = Application.Trim(b(i, 5))
        If d(krt) < 1 Then
            say = say + 1
            For y = 1 To UBound(b, 2): c(say, y) = b(i, y): Next y
        End If
    Next i
    
    If say > 0 Then
        s2.[A2].Resize(UBound(a), UBound(b, 2)).ClearContents
        s2.[A2].Resize(say, UBound(b, 2)) = c
    End If
s2.Select
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Asri]

Alternatif,

Sub sil()
    sonsatir = Sheets("1").Cells(Rows.Count, "A").End(3).Row
    For i = 2 To sonsatir
        Set sayfak = Sheets("TicimaxUrunler").Range("E:E").Find(Sheets("1").Cells(i, "A").Value, , xlValues, xlWhole)
        If Not sayfak Is Nothing Then
           Sheets("TicimaxUrunler").Rows(sayfak.Row).Delete
        End If
    Next i
End Sub

 

[ismailozkan4224]

Dim a(), b(), c(), d As Object Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet Dim i As Long, say As Long, y As Byte Set s1 = Sheets("1") Set s2 = Sheets("TicimaxUrunler") Set d = CreateObject("scripting.dictionary") a = s1.Range("A2:A" & s1.Cells(Rows.Count, 1).End(3).Row).Value For i = 1 To UBound(a) krt = Application.Trim(a(i, 1)) d(krt) = d(krt) + 1 Next i b = s2.Range("A2:BG" & s2.Cells(Rows.Count, 1).End(3).Row).Value ReDim c(1 To UBound(b), 1 To UBound(b, 2)) For i = 1 To UBound(b) krt = Application.Trim(b(i, 5)) If d(krt) < 1 Then say = say + 1 For y = 1 To UBound(b, 2): c(say, y) = b(i, y): Next y End If Next i If say > 0 Then s2.[A2].Resize(UBound(a), UBound(b, 2)).ClearContents s2.[A2].Resize(say, UBound(b, 2)) = c End If s2.Select MsgBox "İşlem tamam.", vbInformation End Sub

teşekkür ederim ziyneddin bey. harika