eski mükerrer kayıtları silmek

[burhancavus61]

mükerrer olan kayıtları yinelenenleri kaldır ile kaldırıyorum. ama son eklenenleri kaldırıyor. ben önce eklenenleri nasıl kaldırabilirim.

 

[burhancavus61]

Silme işlemini aşağıdaki kod ile yapıyorum. Tabiki odasondaki yinelenenleri siliyor. İlk yinelenenleri silmek için bu koda bi ilave yapılabilirmi.

    Columns("K:K").Select
    ActiveSheet.Range("$A$2:$K$100000").RemoveDuplicates Columns:=8, Header:= _
        xlYes

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub M_Sil()
    
    Dim d As Object, i As Long, deg As String, k As Range

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")

    For i = Cells(Rows.Count, "K").End(xlUp).Row To 2 Step -1
        deg = Cells(i, "K")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        Else
            If k Is Nothing Then
                Set k = Rows(i)
            Else
                Set k = Application.Union(k, Rows(i))
            End If
        End If
    Next i
    
    On Error Resume Next
    k.EntireRow.Delete
 
End Sub

 

[burhancavus61]

Hocam bunu tüm kodların arasında çalıştıramıyorum. Kendimce bişeyler yaptığım için sizin kod ekleyince hata verdi normalde sizin kod çalışıyor. bu koda ilave edince hata verdi. Sizin kodlar 72. satırdan itibaren başlıyor. Makrom baya karışık zorla istediğim hale getirebildim.

Sub ArsivP()
Application.ScreenUpdating = False
Application.EnableCancelKey = xlDisabled
Bekleyiniz.Show False:    DoEvents      'Userformu gösterdikten sonra kodları işlemeye devam et         '||

Sheets("ArşivP").Select
Range("B3").Select
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Puantaj")
Set s2 = Sheets("ArşivP")
son = s1.Cells(Rows.Count, "J").End(3).row
aranan = Array("X", "İ", "AT", "P", "R", "F", "Mİ", "Üİ", "B", "FA", "XX", "/")
a = s1.Range("K5:AR" & son).Value
ReDim b(1 To Rows.Count, 1 To 4)
    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
            For j = 3 To UBound(a, 2)
                For k = 0 To UBound(aranan)
                    If a(i, j) = aranan(k) Then
                        say = say + 1
                        b(say, 1) = a(i, 1)
                        b(say, 2) = a(i, 2)
                        b(say, 3) = a(1, j)
                        b(say, 4) = a(i, j)
                    End If
                Next k
            Next j
        End If
    Next i
    
    If say > 0 Then
        satir = s2.Cells(Rows.Count, 2).End(3).row
        If satir < 4 Then satir = 3
        s2.Cells(satir, 2).Resize(say, 4).NumberFormat = "@"
        s2.Cells(satir, 3).Resize(say, 4).NumberFormat = "@"
        s2.Cells(satir, 4).Resize(say, 4).NumberFormat = "m/d/yyyy"
        s2.Cells(satir, 2).Resize(say, 4) = b
    
    Sheets("ArşivP").Select

'------------------------------------------------------------------
' KOPYALAMA
    Range("F3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(RC8,ArşivF.M.!R3C1:R5000C26,11,FALSE),"""")"
    Range("G3").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(RC8,ArşivF.M.!R3C1:R5000C26,17,FALSE),"""")"
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "=RC[-6]&RC[-4]"
    
    Range("F3:H3").Select
    Selection.Copy
    Range("F4:H100000").Select
    ActiveSheet.Paste
    
    Columns("A:A").Select
    Selection.NumberFormat = "General"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=RC[7]"
    Range("A3").Select
    Selection.Copy
    Range("A3:A100000").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("F3").Select
'------------------------------------------------------------------
'Tekrarlanan kişileri silme
'    Columns("K:K").Select
'    ActiveSheet.Range("$A$2:$K$100000").RemoveDuplicates Columns:=8, Header:= _
'        xlYes
   Dim d As Object, i As Long, deg As String, h As Range
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    For i = Cells(Rows.Count, "H").End(xlUp).row To 2 Step -1
        deg = Cells(i, "H")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        Else
            If h Is Nothing Then
                Set h = Rows(i)
            Else
                Set h = Application.Union(h, Rows(i))
            End If
        End If
    Next i
    On Error Resume Next
    h.EntireRow.Delete
'------------------------------------------------------------------
'DÜZENLEME
    Columns("B:E").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("F:F").Select
    Selection.NumberFormat = "hh:mm;@"
    Columns("G:G").Select
    Selection.NumberFormat = "General"
    Range("B3").Select
    ActiveWindow.SmallScroll Down:=-3
    Else
        MsgBox "Aktarılacak veri bulunamadı.", vbCritical
    End If
    Unload Bekleyiniz
End Sub

 

[Ömer]

Nasıl bir hata veriyor. Örnek eklemeniz mümkün mü.

 

[burhancavus61]

tamam hocam hallettim teşekkür ederim.