B sütunundakilerini karşılaştırarak mükerrer olanının küçük tarihlisinin satırını sil

[mersilen]

Herkese kolay gelsin
Bir konuda yardımcı olabilir misiniz?

--B sütunundakilerini karşılaştırarak mükerrer olanının küçük tarihlisinin satırını silecek
-- Sildikten sonra aradaki boş satırları silerek dolu olanları birbirine yaklaştıracak macro yazmaya yardım adebilir misiniz
--

 

[Ömer]

Merhaba,

Module kopyalarak çalıştırınız..

Sub MükererOlupKüçükOlanıSil()
Application.ScreenUpdating = False
Dim i As Long, son As Long
son = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A1:H" & son).Sort Range("A1"), xlDescending
Rows(1).Insert Shift:=xlDown
On Error Resume Next: ActiveSheet.ShowAllData
Range("B1:B" & son).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For i = son To 1 Step -1
        If Rows(i).Hidden = True Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
Rows(1).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

 

[mersilen]

ömer bey çok teşekkür ederim.
Sorunsuz çalışıyor

 

[mersilen]

tekrar merhaba
2010 yılında tarih sorunsuz çalışırken
2011 yılına geçince 2010 ile 2011 tarihli mükerrerlerin en küçüğünü silmesi gerekirken 2011 olanı siliyor
kodu değerlendirmemiz mümkün mü?

Sub MükererOlupKüçükOlanıSil()
Application.ScreenUpdating = False
Dim i As Long, son As Long
son = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A20:EA" & son).Sort Range("A20"), xlDescending
Rows(1).Insert Shift:=xlDown
On Error Resume Next: ActiveSheet.ShowAllData
Range("B20:B" & son).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For i = son To 20 Step -1
        If Rows(i).Hidden = True Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
Rows(1).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

 

[Ömer]

Siz tarihe göre değil B sütununa göre silme işlemi yapıyordunuz.

Ayrıca başlık satırı kullanmadığınız için kodu aşağıdaki gibi değiştiriniz..

Sub MükererOlupKüçükOlanıSil()
Application.ScreenUpdating = False
Dim i As Long, son As Long
son = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A20:EA" & son).Sort Range("A20"), xlDescending
Rows([COLOR=red]20[/COLOR]).Insert Shift:=xlDown
On Error Resume Next: ActiveSheet.ShowAllData
Range("B20:B" & son).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For i = son To 20 Step -1
        If Rows(i).Hidden = True Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
Rows([COLOR=red]20[/COLOR]).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

.

 

[mersilen]

Ömer bey ilginize teşekkür ederim
ama sorun düzelmedi

mesaj 4 deki dosyayı güncelledim ; mavi satırlar kalacak


1. satır başlık satırı olarak kullanıyorum
19. satıra kadarki kısmı ileride düzeltmeler eklemek için boş bırakmıştım
20. satırdan sonrakilerde en alt kısma web sayfasından veri taşıyıp kodu çalıştırdığımızda B20:B deki mükerrerleri bulup A sütunundaki eski tarihlileri siliyordu sadece en son olan kalıyordu
---eski kodu çalıştırdığım zaman 2010 için sorunsuz çalışıyordu ( yalnız biz bunu sanırım 17 aralık 2010 gibi yapmıştık ve 31 aralık a kadar sorunsuz çalıştı, acaba günler arttığı için mi sorunsuzdu?)
---30 aralık 2010 ve 2 ocak 2011 olunca mı sorun yaşadık ?

 

[Ömer]

İlk mesajdaki tarihlere dikkat etmemiştim. Tarihle saati ayırırken "-" kullandığınız için sorun oluyor.

Bu şekilde deneyiniz..

Sub MükererOlupKüçükOlanıSil()
Application.ScreenUpdating = False
Dim i As Long, son As Long
son = Cells(Rows.Count, "A").End(xlUp).Row
Range("A20:A" & son).Replace "-", ""
Range("A20:EA" & son).Sort Range("A20"), xlDescending
    For i = son To 20 Step -1
        If WorksheetFunction.CountIf(Range("B20:B" & son), _
        Cells(i, "B").Value) > 1 Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
Application.ScreenUpdating = True
End Sub

.

 

[mersilen]

tekrar selam
ömer bey hala farklı yıla ait tarih sorunu çözülemedi

 

[Ömer]

Bende hatasız çalıştı. Üstelik olayın farklı yılla ilgisi yok. "-" ile ilgisi vardı,

Range("A20:A" & son).Replace "-", ""

kodunu ekleyerek o sorun halledildi.

Hata aldığınız dosyayı eklermisiniz.

.

 

[mersilen]

Ömer bey ilginize tekrar teşekkür ederim

mesaj 4 deki dosyayı tekrardan güncelledim
sayfa 3 de webden kopyaladığım bilgide var
sayfa 2 deki kodla sayfa 3 deki bilgileri sayfa 3 e çekiyorum
modüldekiylede yeni tarihe göre sıralıyordum
modül 1-2-3 de kodlar sırasıyla yazıyor
sayfa 2 dekileride eski tarihlere göre renklendirdim

 

[Ömer]

#7 nolu mesajda verdiğim kodu kullanmamışsınız.Diğer kodlarıda silebilirsiniz..

.

 

[mersilen]

Ömer bey
dediğiniz gibi yaptım yine de olmadı
acaba benim excel eklentilerim mi yanlış dersiniz
şu an excel 2010 kullanıyorum
--sadece modülü çalıştırınca sayfa 4 deki sonucu
--sayfa2 deki worksheetdeki kodu çalıştırıp modülü çalıştırınca sayfa5 deki sonucu
--sayfa2 dekileri 20.satırdan itibaren silip worksheetdeki kodu çalıştırıp modülü çalıştırınca sayfa6 deki sonucu alıyorum (benim mantığıma görede sonuç böyle olmalı)

 

[Ömer]

Sayın mersilen,

Verileri karıştırıyorsunuz gibi geliyor bana. Kod eklemeden tek bir sayfa ekleyerek yeni bir dosya eklermisiniz. Buradan size çalışma mantığını açıklamaya çalışırım. Diğer türlü aynı şeyleri tekrarlayıp duruyorum. Bu şekilde konu gereksiz uzuyor.

.

 

[mersilen]

ömer bey kusura bakmayın
bugün benim için yoğun bir gündü, belki bende tam olarak izah edememiş yada frekanslarımız tutmamış olabilir
yeniden daha anlaşılır bir tablo ekledim
--sütun içinde mükerrerleri renklendirdim,
--ayrıca yeni tarihli gelmesi gereken satırı komple aynı renk yapmaya özen gösterdim

 

[Ömer]

Bu şekilde deneyiniz..

Sub MükererOlupKüçükOlanıSil()
Application.ScreenUpdating = False
Dim i As Long, son As Long
son = Cells(Rows.Count, "A").End(xlUp).Row - 1
Range("A20:A" & son).Replace "-", ""
For i = 20 To son
    Cells(i, "A") = CDate(Cells(i, "A"))
Next i
Range("A20:EA" & son).Sort Range("A20"), xlDescending
    For i = son To 20 Step -1
        If WorksheetFunction.CountIf(Range("B20:B" & son), _
        Cells(i, "B").Value) > 1 Or Cells(i, "B") = "" Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
Application.ScreenUpdating = True
End Sub

.

 

[mersilen]

Ömer bey,
gerçekten çok teşekkür ederim.
Şu ana kadar ki denemelerimde sorunsuz çalışıyor.

 

[Ömer]

Rica ederim, iyi çalışmalar..