Mükerrer rapor

[acar6783]

Merhabalar,
25000satırlık raporda aşağıdaki gibi bir kod yazdım fakat mükkerrer olan kayıtları süzemedim.
farklı önerisi olan varmıdır?

Sub SÜZ()
     Dim con As Object, RS As Object, sorgu As String
 
    Set con = CreateObject("Adodb.Connection")
    Set RS = CreateObject("Adodb.RecordSet")
   Cells.Delete

        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no"""
        sorgu = "Select f1,f3,f8,(F3&'-' &f5&'-'&f8),f6 from [rapor$] group by f1,f3,f8,(F3&'-' & f5 &'-' & f8),f6 having count((F3&'-' & f5 &'-' & f8)) >1"
        RS.Open sorgu, con, 1, 3
       Range("A2").CopyFromRecordset RS
        RS.Close: con.Close

    Set con = Nothing: Set RS = Nothing: sorgu = ""
End Sub

 

[Mustafa MUTLU]

Sub Mükerrerler()
Dim mm, mutlu, MMutlu
MMutlu = MsgBox("Verileri Tek'e Düşürüyorum", vbYesNo, "Onay")
If MMutlu = vbNo Then Exit Sub
Application.ScreenUpdating = False
mutlu = 2
For mm = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Range("A2:A" & mm), Cells(mm, "A")) = 1 Then
Cells(mutlu, "E") = Cells(mm, "A")
mutlu = mutlu + 1
End If
Next
Application.ScreenUpdating = True
End Sub


Veriler A sütununda varsayarak E sütununa Mükerrerleri teke düşürür (Mükerrersiz sıralanır)

 

[acar6783]

yani herkes mi sadece mükerrerkayıtları silmek için sorar anlamadım..

 

[acar6783]

Aağıdaki kodubuldum ama enteresan başka sayfayasüzem işlemi yapamadım.

Sub CountCol123()
    Dim DCT As Dictionary
    Dim V As Variant
    Dim WS As Worksheet, R As Range
    Dim I As Long
    Dim sKey As String

Set WS = Worksheets("rapor")

'read the info into an array
With WS
    Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=8)
    V = R
End With

'Get count of the matches
Set DCT = New Dictionary
For I = 2 To UBound(V, 1)
    sKey = V(I, 3) & "|" & V(I, 5) & "|" & V(I, 8)
    If DCT.Exists(sKey) Then
        DCT(sKey) = DCT(sKey) + 1
    Else
        DCT.Add Key:=sKey, Item:=1
    End If
Next I

'Get the results and write them out
For I = 2 To UBound(V, 1)
    sKey = V(I, 3) & "|" & V(I, 5) & "|" & V(I, 8)
    If DCT(sKey) > 1 Then
        c = c + 1
    V(c, 4) = DCT(sKey)

    V(c, 5) = sKey
  End If
Next I

With R
    .EntireColumn.Clear
    .Value = V
End With

End Sub

 

[YUSUF44]

Örnek bir dosya paylaşıp hangi şartlara uyan verilerin hangi sayfaya aktarılacağını belirtirseniz yardımcı olmaya çalışırız.

 

[acar6783]

Kodlarımı tekrar derledim. bir iki hatalı kayıt çıkıyor onun dışında sorunum kalmadı .Teşekkür ederim.

Sub SÜZ()
     Dim con As Object, RS As Object, sorgu As String


    Set con = CreateObject("Adodb.Connection")
    Set RS = CreateObject("Adodb.RecordSet")
   Cells.Delete
SOR = "Select F1 FROM [rapor$] WHERE F8 IN(Select f8 from [rapor$] group by F3,F5,f8,F6 having count(f8)>=2)"
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no"""
        sorgu = "SELECT F1,F3,F5,F8,F6,F24 FROM [rapor$] WHERE F1 IN(" & SOR & ")ORDER BY F1,F3 "
        RS.Open sorgu, con, 1, 3
       Range("A2").CopyFromRecordset RS
        RS.Close: con.Close
 
    Set con = Nothing: Set RS = Nothing: sorgu = ""
End Sub