Aynı belge numaraları silmek

1903emre34@gmail.com · Cuma saat 22:44'de

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 · Dün 16:41 da

Kod:

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 · Dün 18:49 da

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

pitchoute · Dün 18:58 da

Merhaba, belge numaralarının olduğu (makroda belgeNoSutunu = 1 ' A sütunu) ve hesap kodunun olduğu (makroda hesapKodSutunu = 2 ' B sütunu ) sütunları kendi excel dosyanıza göre düzenleyip, muhakkak yedek aldıktan sonra deneyebilir misiniz;

Kod:

Sub TekrarlananKayitlariSil()
    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long, j As Long
    Dim belgeNo As String, hesapKod As String
    Dim silinecekSatirlar As New Collection
    Dim silinecekSatir As Boolean
    Dim satirIndex As Long
    
    On Error Resume Next
    Set ws = ActiveSheet
    sonSatir = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim belgeNoSutunu As Integer
    belgeNoSutunu = 1
    
    Dim hesapKodSutunu As Integer
    hesapKodSutunu = 2
    
    For i = 2 To sonSatir
        belgeNo = ws.Cells(i, belgeNoSutunu).Value
        hesapKod = Left(ws.Cells(i, hesapKodSutunu).Value, 3)
        silinecekSatir = False
        
        For Each satirIndex In silinecekSatirlar
            If satirIndex = i Then
                silinecekSatir = True
                Exit For
            End If
        Next satirIndex
        
        If Not silinecekSatir Then
            For j = i + 1 To sonSatir
                If belgeNo = ws.Cells(j, belgeNoSutunu).Value Then
                    If hesapKod = Left(ws.Cells(j, hesapKodSutunu).Value, 3) Then
                        On Error Resume Next
                        silinecekSatirlar.Add j, CStr(j)
                        On Error GoTo 0
                    End If
                End If
            Next j
        End If
    Next i
    Dim tempArray() As Long
    Dim arrayIndex As Long
    
    If silinecekSatirlar.Count > 0 Then
        ReDim tempArray(1 To silinecekSatirlar.Count)
        arrayIndex = 1
        
        For Each satirIndex In silinecekSatirlar
            tempArray(arrayIndex) = satirIndex
            arrayIndex = arrayIndex + 1
        Next
        Call QuickSort(tempArray, 1, UBound(tempArray))
        
        For i = UBound(tempArray) To 1 Step -1
            ws.Rows(tempArray(i)).Delete
        Next i
        MsgBox silinecekSatirlar.Count & " satır silindi.", vbInformation
    Else
        MsgBox "Silinecek tekrarlanan kayıt bulunamadı.", vbInformation
    End If
End Sub

Sub QuickSort(arr() As Long, low As Long, high As Long)
    Dim pivot As Long
    Dim tmp As Long
    Dim i As Long
    Dim j As Long
    
    If low < high Then
        pivot = arr(low)
        i = low
        j = high
        
        Do
            Do While arr(i) < pivot And i < high
                i = i + 1
            Loop
            
            Do While arr(j) > pivot And j > low
                j = j - 1
            Loop
            
            If i <= j Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
                i = i + 1
                j = j - 1
            End If
        Loop Until i > j
        
        If low < j Then QuickSort arr, low, j
        If i < high Then QuickSort arr, i, high
    End If
End Sub

1903emre34@gmail.com · Dün 19:16 da

İndir Kitap1 (2) excelweb zip

Dosyayı indir Kitap1 (2) excelweb zip

dosya.co

Dosya ektedir.

pitchoute · Dün 21:43 da

Merhaba tekrardan, yedek aldıktan sonra şunu kullanabilirsiniz;

Kod:

Sub TekrarlananKayitlariSil()
    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long, j As Long
    Dim belgeNo As String, hesapKod As String
    Dim silinecekSatirlar() As Long
    Dim satirSayisi As Long
    Dim varMi As Boolean
    
    Set ws = ActiveSheet
    sonSatir = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Dim belgeNoSutunu As Integer
    belgeNoSutunu = 4
    Dim hesapKodSutunu As Integer
    hesapKodSutunu = 1
    
    ReDim silinecekSatirlar(0 To 0)
    satirSayisi = 0
    
    For i = 2 To sonSatir
        belgeNo = ws.Cells(i, belgeNoSutunu).Value
        hesapKod = Left(ws.Cells(i, hesapKodSutunu).Value, 3)
        
        varMi = False
        If satirSayisi > 0 Then
            For j = 0 To satirSayisi - 1
                If silinecekSatirlar(j) = i Then
                    varMi = True
                    Exit For
                End If
            Next j
        End If
        
        If Not varMi Then
            For j = i + 1 To sonSatir
                If belgeNo = ws.Cells(j, belgeNoSutunu).Value Then
                    If hesapKod = Left(ws.Cells(j, hesapKodSutunu).Value, 3) Then
                        ReDim Preserve silinecekSatirlar(0 To satirSayisi)
                        silinecekSatirlar(satirSayisi) = j
                        satirSayisi = satirSayisi + 1
                    End If
                End If
            Next j
        End If
    Next i
    
    If satirSayisi > 0 Then
        Call QuickSort(silinecekSatirlar, 0, satirSayisi - 1)
        
        For i = satirSayisi - 1 To 0 Step -1
            ws.Rows(silinecekSatirlar(i)).Delete
        Next i
        MsgBox satirSayisi & " satır silindi.", vbInformation
    Else
        MsgBox "Silinecek tekrarlanan kayıt bulunamadı.", vbInformation
    End If
End Sub

Sub QuickSort(arr() As Long, low As Long, high As Long)
    Dim pivot As Long
    Dim tmp As Long
    Dim i As Long
    Dim j As Long
    
    If low < high Then
        pivot = arr(low)
        i = low
        j = high
        
        Do
            Do While arr(i) < pivot And i < high
                i = i + 1
            Loop
            
            Do While arr(j) > pivot And j > low
                j = j - 1
            Loop
            
            If i <= j Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
                i = i + 1
                j = j - 1
            End If
        Loop Until i > j
        
        If low < j Then QuickSort arr, low, j
        If i < high Then QuickSort arr, i, high
    End If
End Sub

1903emre34@gmail.com · Dün 22:23 da

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 · Bugün 00:30

Kod:

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 · Bugün 00:46

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

Ziynettin · Bugün 01:00

Kod:

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

Aynı belge numaraları silmek

1903emre34@gmail.com

Ekli dosyalar

veyselemre

Özel Üye

1903emre34@gmail.com

pitchoute

1903emre34@gmail.com

İndir Kitap1 (2) excelweb zip

pitchoute

1903emre34@gmail.com

İndir Kitap1 (2) excel 111 yen, zip

Ziynettin

Destek Ekibi

1903emre34@gmail.com

Ekli dosyalar

Ziynettin

Destek Ekibi