Aynı belge numaraları silmek

[1903emre34@gmail.com]

Aynı belge numarada, aynı belge numarası içinde hesap kodunu ilk üç hanesi aynısı ise o satırı silmek için kod oluşturabilir miyiz

 

[veyselemre]

Sub test()
    Dim rng As Range, r, ky, rSil As Range
    Set rng = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
    With CreateObject("Scripting.Dictionary")
        For Each r In rng.Rows
            ky = Left(r.Cells(1).Value, 3) & vbTab & r.Cells(4)
            If Not .exists(ky) Then
                Set .Item(ky) = r.Cells(1)
            Else
                If rSil Is Nothing Then
                    Set rSil = Union(.Item(ky), r.Cells(1))
                Else
                    Set rSil = Union(rSil, .Item(ky), r.Cells(1))
                End If
            End If
        Next r
    End With
    If Not rSil Is Nothing Then rSil.Select    'rSil.EntireRow.Delete
End Sub

 

[1903emre34@gmail.com]

ilginiz için teşekkürker, kodu çalıştırdım herhangi satır silmed.

 

[1903emre34@gmail.com]

İndir Kitap1 (2) excelweb zip

Dosyayı indir Kitap1 (2) excelweb zip

dosya.co

Dosya ektedir.

 

[1903emre34@gmail.com]

49 bin satır var, kilitleniyor.

yukarıdaki dosyada denedim, sonuç sayfasındaki belge numaraları hepsini silmiyor . istenen sayfa1 yapılmıştır.

İndir Kitap1 (2) excel 111 yen, zip

Dosyayı indir Kitap1 (2) excel 111 yen, zip

dosya.co

 

[Ziynettin]

Sub test()
Dim sh1 As Worksheet, a(), b(), dc As Object
Dim son As Long, say As Long, krt As String
Dim i As Long, y As Byte

Set sh1 = Sheets("Sayfa1")
Set dc = CreateObject("scripting.dictionary")
son = sh1.Range("A" & Rows.Count).End(3).Row

a = sh1.Range("A1:L" & son).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))

For i = 2 To UBound(a)
    krt = Left(a(i, 1), 3) & "|" & a(i, 4)
    If Not dc.exists(krt) Then
        dc(krt) = dc.Count + 1
        say = dc.Count
        For y = 1 To UBound(a, 2)
            b(say, y) = a(i, y)
        Next y
    End If
Next i

Application.ScreenUpdating = False
sh1.Range("A2:L" & Rows.Count).ClearFormats
sh1.Range("A2:L" & Rows.Count).ClearContents
If dc.Count > 0 Then
    sh1.[A2].Resize(dc.Count).NumberFormat = "@"
    sh1.[C2].Resize(dc.Count).NumberFormat = "dd.mm.yyyy"
    sh1.[F2].Resize(dc.Count).NumberFormat = "#,##0.00"
    sh1.[H2].Resize(dc.Count).NumberFormat = "#,##0.00"
    sh1.[A2].Resize(dc.Count, UBound(a, 2)).Borders.Color = rgbSilver
    sh1.[A2].Resize(dc.Count, UBound(a, 2)) = b
    sh1.[A2].Resize(dc.Count, UBound(a, 2)).Font.Size = 9
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[1903emre34@gmail.com]

İlginiz için teşekkürler, ekteki dosyada renkli silinmesi için kodlarda değişiklik yapabilir miyiz

 

[Ziynettin]

Sub test2()
Dim sh1 As Worksheet, a(), b(), dc As Object
Dim son As Long, say As Long, krt As String
Dim i As Long, y As Byte, ds As Object

Set sh1 = Sheets("Sayfa1")
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")


son = sh1.Range("A" & Rows.Count).End(3).Row

a = sh1.Range("A1:L" & son).Value

For i = 2 To UBound(a)
    krt = Left(a(i, 1), 3) & "|" & a(i, 4)
    ds(krt) = ds(krt) + 1
Next i



ReDim b(1 To UBound(a), 1 To UBound(a, 2))

For i = 2 To UBound(a)
    krt = Left(a(i, 1), 3) & "|" & a(i, 4)
    If ds(krt) = 1 Then
    If Not dc.exists(krt) Then
        dc(krt) = dc.Count + 1
        say = dc.Count
        For y = 1 To UBound(a, 2)
            b(say, y) = a(i, y)
        Next y
    End If
    End If
Next i

Application.ScreenUpdating = False
sh1.Range("A2:L" & Rows.Count).ClearFormats
sh1.Range("A2:L" & Rows.Count).ClearContents
If dc.Count > 0 Then
    sh1.[A2].Resize(dc.Count).NumberFormat = "@"
    sh1.[C2].Resize(dc.Count).NumberFormat = "dd.mm.yyyy"
    sh1.[F2].Resize(dc.Count).NumberFormat = "#,##0.00"
    sh1.[H2].Resize(dc.Count).NumberFormat = "#,##0.00"
    sh1.[A2].Resize(dc.Count, UBound(a, 2)).Borders.Color = rgbSilver
    sh1.[A2].Resize(dc.Count, UBound(a, 2)) = b
    sh1.[A2].Resize(dc.Count, UBound(a, 2)).Font.Size = 9
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[veyselemre]

Sub test()
    Dim rng As Range, r, ky, rSil As Range
    Set rng = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
    With CreateObject("Scripting.Dictionary")
        For Each r In rng.Rows
            ky = Left(r.Cells(1).Value, 3) & vbTab & r.Cells(4)
            If Not .exists(ky) Then
                Set .Item(ky) = r.Cells(1)
            Else
                If rSil Is Nothing Then
                    Set rSil = Union(.Item(ky), r.Cells(1))
                Else
                    Set rSil = Union(rSil, .Item(ky), r.Cells(1))
                End If
            End If
        Next r
    End With
    If Not rSil Is Nothing Then rSil.EntireRow.Delete
End Sub