Yinelenen değerleri şarta göre silme.

[Biray3550]

Merhaba, A Kolonundaki yinelenen değerleri D Kolonundaki veri sıfır ise sıfır olan yinelenen değerlerin olduğu satırı silmeyi nasıl hızlandırabilirim?
Aşağıdaki macro çok yavaş çalışıyor.Veri 150 Bin olduğu için.
Teşekkür ederim.



Sub SilYinelenenVeSifir()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim lastRow As Long
Dim rng As Range
Dim cel As Range
Dim dict As Object

Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For Each cel In ws.Range("A1:A" & lastRow)
If Not dict.Exists(cel.Value) Then
dict.Add cel.Value, cel.Row
Else
If ws.Cells(cel.Row, "D").Value = 0 Then
ws.Rows(cel.Row).Delete
End If
End If
Next cel

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[Cengiz Demir]

Makrosuz çözüm isterseniz.
Listeyi filtreleyin. Stok kodunu renge göre, Alış Fiyatını 0 olarak filtreleme yapın.
Süzülmüş satırları silin.

 

[Biray3550]

Onu biliyorum. Teşekkür ederim.

 

[NADİR YILDIZ]

sayın biray kendi çalışmanıza kodları kopyalayıp kontrol edermisiniz

 

[Ziynettin]

Bu şekilde deneyin.

Sub test()
Dim a(), b(), dc As Object, ds As Object
Dim s1 As Worksheet, son As Long, Say As Long
Dim i As Long, j As Byte, krt As String, krt1 As Long
Set s1 = Sheets("veri")
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
son = s1.Range("A" & Rows.Count).End(3).Row

a = s1.Range("A1:D" & son).Value
ReDim b(1 To UBound(a), 1 To 4)

For i = 2 To UBound(a)
    If a(i, 1) <> "" Then
        krt = CStr(a(i, 1))
        dc(krt) = dc(krt) + 1
        If a(i, 4) = 0 Then
            If dc(krt) > 1 Then ds(i) = ""
        End If
        krt1 = i
        If Not ds.exists(krt1) Then
            Say = Say + 1
            For j = 1 To 4
                b(Say, j) = a(i, j)
            Next j
        End If
    End If
Next i

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Say >= 0 Then
    s1.Range("A2:D" & son).ClearContents
    s1.[A2].Resize(Say, 4) = b

End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Biray3550]

Teşekkür ederim. Elinize sağlık.