Excelde Tekrarlayan Veriler şartlara göre silme

[ahmetyol]

https://i.hizliresim.com/2wlkjsm.PNG

AYNI OLAN SAYILARI TEK SÜTÜNE TARİH VE SON GİRİŞ TARİHİNE GÖRE TEKE DÜŞÜRMEK MÜMKÜNMÜ

 

[Haluk]

"Sheet1" isimli sayfada aşağıdaki resimde belirtilen verileriniz varsa;





Aşağıdaki resimde belirtildiği şekilde verileri yine "Sheet1" isimli sayfada bu kez K-L-M sütunlarında listelemek için, aşağıdaki kodu kullanabilirsiniz.

Sub Test()
    Dim objConn As Object, RS As Object, SQLdata As String, strSQL As String, strArgs As String

    Sheets("Sheet1").Range("K2:M" & Rows.Count).ClearContents

    Set objConn = CreateObject("ADODB.Connection")

    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; Readonly=False; DBQ=" & ThisWorkbook.FullName
    objConn.Open strArgs

    strSQL = " Select [Barkod], [Urun], Max([Tarih]) From [Sheet1$] Group By [Barkod], [Urun]"

    Set RS = objConn.Execute(strSQL)

    Sheets("Sheet1").Range("K2").CopyFromRecordset RS

    objConn.Close
    Set objConn = Nothing
End Sub

.

 

[dEdE]

Merhaba,
Üstada alternatif olmaz ama, ben de bir şeyler yazmıştım.
Eklediğiniz resimden barkod numaralarının "J" sütununda olduğunu ve tarihlerin de resimdeki gibi her ürün için küçükten büyüğe sıralı olduğunu varsaydım. Barkod numaraları başka sütunda ise, koddaki sütun adını değiştirmelisiniz.
Kod ilgili sayfadaki (Sayfa adı görülmediği için, aktif sayfa olarak aldım.) aynı barkod numarasına sahip ürünlerden en yeni tarihli olan dışındakilerin bulunduğu satırları siler.
Dosyanızın yedeğini aldıktan sonra denemenizi öneririm.

Sub sil()
    For sat = 1 To Cells(Rows.Count, 10).End(3).Row
        If WorksheetFunction.CountIf(Range("J:J"), Cells(sat, 10)) > 1 Then Rows(sat).ClearContents
    Next
    Range("J1").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub

 

[ahmetyol]

"Sheet1" isimli sayfada aşağıdaki resimde belirtilen verileriniz varsa;


Ekli dosyayı görüntüle 250578


Aşağıdaki resimde belirtildiği şekilde verileri yine "Sheet1" isimli sayfada bu kez K-L-M sütunlarında listelemek için, aşağıdaki kodu kullanabilirsiniz.

Ekli dosyayı görüntüle 250579

Sub Test()
    Dim objConn As Object, RS As Object, SQLdata As String, strSQL As String, strArgs As String

    Sheets("Sheet1").Range("K2:M" & Rows.Count).ClearContents

    Set objConn = CreateObject("ADODB.Connection")

    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; Readonly=False; DBQ=" & ThisWorkbook.FullName
    objConn.Open strArgs

    strSQL = " Select [Barkod], [Urun], Max([Tarih]) From [Sheet1$] Group By [Barkod], [Urun]"

    Set RS = objConn.Execute(strSQL)

    Sheets("Sheet1").Range("K2").CopyFromRecordset RS

    objConn.Close
    Set objConn = Nothing
End Sub

.

ustam tüm sütünları attım buna göre uyarlanır mı acaba

 

[dEdE]

#3 no.lu mesaja ekli kod işe yaramadı mı?

 

[ahmetyol]

#3 no.lu mesaja ekli kod işe yaramadı mı?

ustam yapamadım

 

[dEdE]

ustam yapamadım

Neyi yapamadınız?
-Kodu modüle aktarmayı mı?
-Kodu bir butona atamayı mı?
-Kod çalışmadı mı?
-Çalıştı da istediğinizi yağmadı mı? . . . . sorular ve yanıtlar uzayıp gidecek.

Örnek dosyanızın ekran görüntüsü yerine dosyanın kendisini paylaşmayı düşünüyor musunuz?

 

[ahmetyol]

Neyi yapamadınız?
-Kodu modüle aktarmayı mı?
-Kodu bir butona atamayı mı?
-Kod çalışmadı mı?
-Çalıştı da istediğinizi yağmadı mı? . . . . sorular ve yanıtlar uzayıp gidecek.

Örnek dosyanızın ekran görüntüsü yerine dosyanın kendisini paylaşmayı düşünüyor musunuz?

Kusura bakmayın altın üyelik olmadıgı için ilk başta link atabildim üyelik onaylanınca aklıma gelmedi excell halini atmam örnek olarak attıyorum şartlara göre (giriş barkod son tarih) göre verileri teke düşürmek istiyorum

 

[dEdE]

Dener misiniz?

 

[Haluk]

ustam tüm sütünları attım buna göre uyarlanır mı acaba

    strSQL = " Select [Ürün Tipi], [Alt Grup], [Stok Açıklama], [Birim], [Türü], [Barkod], [Cari Kodu], [Ünvan], [Seri], [Fatura No], [Depo], [Birim Fiyatı], [Para Birimi],  [Toplam Fiyat(TL)], [Sözleşmeli], [Açıklama], [Şube Adı], Max([Tarih]) From [Sayfa1$] " & _
             " Group By [Ürün Tipi], [Alt Grup], [Stok Açıklama], [Birim], [Türü], [Barkod], [Cari Kodu], [Ünvan], [Seri], [Fatura No], [Depo], [Birim Fiyatı],  [Para Birimi],  [Toplam Fiyat(TL)],    [Sözleşmeli],  [Açıklama], [Şube Adı]"

.

 

[veyselemre]

Bir yaşıma daha girdim bu kod nasıl böyle sarılı satırları silebiliyor. Böyle bir kullanım şekli bana göre kesinlikle mantığa aykırı ama çalışıyor, ilginç ilk defa karşılaştım. Excele de yapay zeka girmiş. Niye 16 ve 18. satırlar silinmedi, sonra satırın silineceğini nerden anladı.

 

[dEdE]

Merhaba veyselemre Hocam,
Bizimkisi biraz deneme yanılma.
VBA konusunda tüm bildiklerimi buradan ve sizlerden öğrendim. Yapay zeka konusuna hiç girmedim. Kodu yazarken önce tekrarlayan satırları bulup içeriğini silmek sonrada Git/ÖzelGit/Boşluklar yoluyla boş satırları silmeyi denedim. Çalıştı.
ADO konusunu bilmediğim için, Sayın Haluk Hocamın yazdığı kodlar dışında farklı kod öneriniz olursa memnun olurum. Ben de yeni bir şey öğrenirim.
Saygılarımla.

 

[veyselemre]

Excel niyet okumuş. İşin sırrı sizin manuel olarak önceden yapmış olduğunuz Özel Git işlemi. Burda ki işlemi tekrar ediyor ilginç. Böyle bir kullanım yok.
Verileri yeni bir excel dosyasına kopyalayıp kodunuzu çalıştırın hata verecektir.

 

[veyselemre]

Sub herUrundenSonGelenGetir_AF()
    Dim rng As Range, rngCriteria As Range, son&
    Sheets("AF").Range("K1:AF" & Rows.Count).ClearContents
    With Sheets("Sayfa1")
        son = .Cells(Rows.Count, 1).End(3).Row
        Set rng = .Range("A1:AF" & son)
        Set rngCriteria = .Range("X1:X2")
        rngCriteria.Cells(2).Formula = "=COUNTIF($J$2:$J$" & son & ",J2)=COUNTIF($J$2:J2,J2)"
        rng.Rows(1).Copy Sheets("AF").Range("K1")
        rng.advancedFilter 2, rngCriteria, Sheets("AF").Range("K1:AF1"), False
        rngCriteria.ClearContents
    End With
End Sub

Sub herUrundenSonGelenGetir_ADO()
    Dim strSQL$
    Sheets("ADO").Range("K2:M" & Rows.Count).ClearContents
    With CreateObject("ADODB.Connection")
        .Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; Readonly=False; DBQ=" & ThisWorkbook.FullName
        strSQL = " SELECT A.* FROM " & _
                 " (SELECT Barkod, MAX(Tarih) AS SonTarih FROM [Sayfa1$] GROUP BY  Barkod) AS B " & _
                 " INNER JOIN [Sayfa1$] A ON (B.SonTarih = A.Tarih) AND (B.Barkod = A.Barkod) "
        Sheets("ADO").Range("K2").CopyFromRecordset .Execute(strSQL)
        .Close
    End With
End Sub

 

[ahmetyol]

Sub herUrundenSonGelenGetir_AF()
    Dim rng As Range, rngCriteria As Range, son&
    Sheets("AF").Range("K1:AF" & Rows.Count).ClearContents
    With Sheets("Sayfa1")
        son = .Cells(Rows.Count, 1).End(3).Row
        Set rng = .Range("A1:AF" & son)
        Set rngCriteria = .Range("X1:X2")
        rngCriteria.Cells(2).Formula = "=COUNTIF($J$2:$J$" & son & ",J2)=COUNTIF($J$2:J2,J2)"
        rng.Rows(1).Copy Sheets("AF").Range("K1")
        rng.advancedFilter 2, rngCriteria, Sheets("AF").Range("K1:AF1"), False
        rngCriteria.ClearContents
    End With
End Sub

elinize saglık bu kodla geliyor veriler işlem bittikten sonra çıkışlarıda FİLRE ile manuel siliyorum kalanı dogru cıkıyor makro ya eklenir mi en son kalan cıkış k / af sütünü arasını silinir mi