çift saydırma

[oydemir]

Formda bulduğum kodlar kullanmaktayım.

Hücre sayısı çoğalınca işlem baya bi vakit alıyor daha kısa bir yolu var mıdır?

Sub Makro3()
Set S1 = Sheets("ada")
For i = 1 To S1.Range("b65536").End(3).Row
deger = WorksheetFunction.CountIf(S1.Range("D1" & i), S1.Cells(i, "D"))
If deger > 1 Then
Cells(i, "D").Select
Cells(i, "a").Value = deger - 1
Selection.Interior.Color = vbYellow
End If
Next
End Sub

 

[muhasebeciyiz]

Alt Optimize()
    Dim S1 As Worksheet
    Dim dict As Object, deger As Long

    Set S1 = Sheets("ada")
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To S1.Range("b65536").End(3).Row
        dict(S1.Cells(i, "D").Value) = dict(S1.Cells(i, "D").Value) + 1
    Next
    
    For i = 1 To S1.Range("b65536").End(3).Row
        deger = dict(S1.Cells(i, "D").Value) - 1
        If deger > 0 Then
            S1.Cells(i, "D").Value = deger
            S1.Cells(i, "a").Value = deger - 1
            S1.Cells(i, "D").İçiRenk.Renk = vbSarı
        End If
    Next

    Set dict = Nothing
End Sub

Deneyiniz

 

[Muzaffer Ali]

Alternatif

Sub Test()
    Dim Bak As Range
    Dim Say As Long

    Say = Sheets("ada").Cells(Rows.Count, "B").End(xlUp).Row
    With Sheets("ada").Range("A1:A" & Say)
        .FormulaLocal = "=EĞERSAY($D$1:D1;D1)-1"
        .Value = .Value
        .Replace What:="0", Replacement:=""
    End With
    For Each Bak In Range("A1:A" & Say).SpecialCells(xlCellTypeConstants, 23)
        Bak(1, 4).Interior.Color = vbYellow
    Next
End Sub

 

[oydemir]

Elinize sağlık teşekkür ederim
gerçekten hızlı olmuş

 

[oydemir]

Muzaffer Ali bey
cifleri saydırırken 0 ları silerken 10 olanlardan 20 gibi sonlarında 0 olanlarda siliyor 10 1 oluyor
çözüm bulabilir miyiz

 

[Muzaffer Ali]

.Replace What:="0", Replacement:=""

satırını aşağıdaki ile değiştirin.

.Replace What:="0", Replacement:="", lookat:=xlWhole

 

[oydemir]

Elinize bilginize sağlık
teşekkürler