Yalnızca Benzersiz Kayıtlar Süzülecek

[KAANGURCAN]

Elimde örneğini gönderdiğim veriler var. Yalnızca benzersiz kayıtlar Kalsın istiyorum. Ama "Veri, Filtre uygula, Gelişmiş filtre, Başka bir yere kopyala, Yalnızca benzersiz kayıtlar." işlemini yaptığımda tekrarlanan kayıtlardan birini de süzüyor. Benim isteğim eğer kayıt tekrarlıysa o veriden hiçbirini almasın.

 

[Ali]

Aşağıdaki kodu deneyin.


Sub mukerrersil()
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).Delete
Next
End Sub

 

[Ali]

Kodu gönderdikten sonra farkettim neye göre kayıtları süzecek yada teke indirecek Hasta kodu aynı olan kişilerin birde sonuç sütunu farklı olanlar var.

 

[KAANGURCAN]

Aşağıdaki kodu deneyin.


Sub mukerrersil()
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).Delete
Next
End Sub

Sayın fructose,

Makroyu çalıştırdım, fakat yinelenen her veriden bir tanesini süzmüş. Benim isteğim eğer veriler yineliyorsa onlardan hiçbirini süzmesin.

Makroyu çalıştırmadan önce ve sonraki durumu EKLİ DOSYADA gönderiyorum.

Cevabınız için de teşekkür ederim

 

[Merhum İdris SERDAR]

Bu kodu deneyin.

Sub Tekraryok()
Worksheets("Sheet1").Range("A2").Sort _
key1:=Worksheets("Sheet1").Range("A2")
Set currentCell = Worksheets("Sheet1").Range("A2")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If nextCell.Value = currentCell.Value Then
currentCell.EntireRow.Delete
End If
Set currentCell = nextCell
Loop
End Sub

 

[Recep İpek]

Birde bu kodları deneyiniz.

G kolonuna sil veya silme yazar.Buna göre sıralayıp silibilirsiniz.

Sub AraBul()
On Error Resume Next
Application.ScreenUpdating = False
Dim a, b As Variant
Dim alan1, alan2 As Range
Range("G3:" & [G65536].End(xlUp).Address).ClearContents
Range("B3").Select
Set alan1 = Range("B3:" & [B65536].End(xlUp).Address)
Set alan2 = Range("I3:" & [I65536].End(xlUp).Address)
'****************************************
For Each a In alan1
s = 0
    For Each b In alan1
        If a.Value = b.Value Then
        s = s + 1
        a.Offset(0, 5).Value = "Sil"
        End If
    Next
    If s = 1 Then a.Offset(0, 5).Value = "Silme"
Next
'*****************************************
MsgBox "Bitti", vbInformation + vbDefaultButton1 + vbOKOnly, "UYARI"
Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[KAANGURCAN]

Sayın yurttas, kodu çalıştıramadım, hata verdi.

Sayın ripek, kod çalışıyor fakat küçük miktardaki verilerde. Elimde 4000-50000 arası veriler var. Bunları ayıkladığımda bilgisayar kilitleniyor. Yani sistemi yavaşlatıyor.

Bilgileriniz için teşekkür ederim.

 

[Merhum İdris SERDAR]

Dosyanız ekte.

 

[Ali]

Alan'a ait kodlardır.Aynı verinin tümünü siler.

Option Explicit
Sub ciftsil()
Dim bDuplicate As Boolean, bDupFound As Boolean
Dim iPtr As Integer
Dim lRow As Long, lRowEnd As Long
Dim vCur(1 To 3) As Variant, vPrev(1 To 3) As Variant
Dim WS As Worksheet
Application.ScreenUpdating = False
Set WS = Sheets("Sayfa1")
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row
For iPtr = 1 To 3
vPrev(iPtr) = WS.Cells(lRowEnd, iPtr).Value
Next iPtr
lRow = lRowEnd
Do
lRow = lRow - 1
If lRow < 2 Then Exit Do
bDuplicate = True
For iPtr = 1 To 3
vCur(iPtr) = WS.Cells(lRow, iPtr).Value
If vCur(iPtr) <> vPrev(iPtr) Then bDuplicate = False
Next iPtr

If bDuplicate = True Then
WS.Rows(lRow).Delete shift:=xlUp
bDupFound = True
Else
If bDupFound = True Then
WS.Rows(lRow + 1).Delete shift:=xlUp
bDupFound = False
End If
For iPtr = 1 To 3
vPrev(iPtr) = WS.Cells(lRow, iPtr).Value
Next iPtr
End If
Loop
Application.ScreenUpdating = True
End Sub

 

[KAANGURCAN]

Dosyanız ekte.

Sayın yurttas,

dosyayı inceledim. fakat ilk söylediğim gibi. tekrarlanan verilerden bir tane almış. Ben hiç almasın istiyorum. 4 nolu mesajımdaki ekli dosyayı açarsanız ne demek istediğimi daha iyi anlayabilirsiniz.

 

[Ali]

Sn Kaangurcan verdi&#287;im kodlar&#305; denediniz mi.

 

[Merhum İdris SERDAR]

Ben dosyay&#305; denedim. Tekrar&#305;n esamesini g&#246;rm&#252;yorum.

&#199;&#252;nk&#252; kodun mant&#305;&#287;&#305; benzeyen b&#305;rakmayacak. Benzyeni yakalad&#305; m&#305;, o sat&#305;r&#305; silecek.

&#304;kinci sayfaya bak&#305;n. orada Listenizin bir yede&#287;i var onu defalarca denedim.

&#350;imdi siz de deneyin. &#304;simleri (ba&#351;l&#305;k sat&#305;r&#305; hari&#231 kopyalay&#305;p A3 h&#252;cresinden itibaren yap&#305;&#351;t&#305;r&#305;n ve tekrar deneyin.

Ben deniyorum ve ekteki listeyi elde ediyorum.

&#304;stedi&#287;iniz b&#246;yle bir liste de&#287;il mi?

 

[KAANGURCAN]

Ben dosyayı denedim. Tekrarın esamesini görmüyorum.

Çünkü kodun mantığı benzeyen bırakmayacak. benzyeni yakaladımı o satırı silecek.

İkinci sayfaya bakın. orada Listenizin bir yedeği var onu defalarca denedim.

Şimdi siz de deneyin. İsmleri (başlık satırı hariç) opyalayıp A3 hücresinden itibaren yapıştırın ve tekrar deneyin.

Ben deniyorum ve ekteki listeyi elde ediyorum.

İstediğiniz böyle bir liste değil mi?

Listeden bir örnek vereyim. Gönderdiğiniz son listeye baktığınızda "A.GALIP CAKA" ismi 4 kez tekrarlanmış. Makro uygulandığında "A.GALIP CAKA" isminin 1 kez tekrarlandığı görülüyor. Oysa ki ben bu ismin hiç olmamasını istiyorum. Yani tekrarlanan öğeleri tamamen silsin. Umarım anlatabilmişimdir.

 

[mehmett]

Ben de bir deneme yaptım.

Dosyanıze ekte.

 

[Ali]

Sn kaangurcan verdiğim kodları denememişsiniz sanırım.
Örneğiniz ekte..

 

[KAANGURCAN]

Ben de bir deneme yaptım.

Dosyanıze ekte.

İŞTE BU....

Sayın mehmett,

Tam istediğim gibi bir çalışma. Bir şey daha sormak istiyorum. Benzersiz kayıtları "ADI SOYADI" na göre değil de "HASTA NO" ya göre bulmasını istiyorum. Formülde nerede değişiklik yapmam gerekiyor.?

 

[mehmett]

Cells(i, 7) = WorksheetFunction.CountIf([B:B], Cells(i, 2))

Bu sat&#305;rda a&#351;a&#287;&#305;daki de&#287;i&#351;ikli&#287;i yap&#305;n;

Cells(i, 7) = WorksheetFunction.CountIf([A:A], Cells(i, 1))

 

[KAANGURCAN]

Sn kaangurcan verdiğim kodları denememişsiniz sanırım.
Örneğiniz ekte..

Şimdi denedim. Sizin formül de harika olmuş. Ne diyeyim. Çok ciddi bir çalışmada kullanacağım bu formül ile önümdeki büyük engeli de aşmış oldum.

Yalnız size de Sayın mehmett'e sorduğum soruyu sormak istiyorum. "HASTA NO" ya göre benzersiz kayıtları bulmasını istiyorum.

 

[KAANGURCAN]

Sorun çözülmüştür.

Herkese paylaşımları çok teşekkür ederim.

 

[mesudiye_052]

formüllerle yapılmış bir çalışmayı gönderiyorum