Mejorar velocidad del procedimiento del codigo

[dragonfire33]

Buenos días como puedo mejorar el procedimiento de el siguiente código

Sub Repetidos()

'Por.Dante Amor

    col = "TG"

    '

    Application.ScreenUpdating = False

    c = Columns(col).Column

    Range(Cells(1, c), Cells(1, c + 2)).EntireColumn.ClearContents

    For Each n In Range("A1:SZ217").SpecialCells(xlCellTypeConstants, 23)

        Set b = Columns(c).Find(n.Value, lookat:=xlWhole)

        If Not b Is Nothing Then

            Cells(b.Row, c + 1) = Cells(b.Row, c + 1) + 1

            Cells(b.Row, c + 2) = Cells(b.Row, c + 2) & ", " & n.Address(False, False)

        Else

            u = Range(col & Rows.Count).End(xlUp).Row + 1

            Cells(u, c) = n.Value

            Cells(u, c + 1) = 1

            Cells(u, c + 2) = n.Address(False, False)

        End If

    Next

    For i = u To 1 Step -1

        If Cells(i, c + 1) = 1 Then

            Range(Cells(i, c), Cells(i, c + 2)).Delete Shift:=xlUp

        End If

    Next

    '

    With ActiveSheet.Sort

        .SortFields.Clear

        .SortFields.Add Key:=Range(Cells(1, c + 1), Cells(u, c + 1)), _

            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

        .SetRange Range(Cells(1, c), Cells(u, c + 2))

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    Application.ScreenUpdating = True

    MsgBox "Fin"

End Sub

 

[DanteAmor]

Buenos días Dragon:

Prueba el siguiente código, le agregué un Dictionary para hacerlo más rápido.

Sub Repetidos_v2()
  Dim dic As Object
  Dim a As Variant, b As Variant, ky As Variant
  Dim col As String, d As String, numS As String, addS As String
  Dim i%, j%, y%, k%
  
  Application.ScreenUpdating = False
  Application.StatusBar = False
  
  col = "TG"
  a = Range("A1:SZ217").Value2
  With Range(col & 1)
    .Resize(1, 3).EntireColumn.ClearContents
    .EntireColumn.NumberFormat = "@"
  End With
  
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      numS = a(i, j)
      addS = Cells(i, j).Address(0, 0)
      If numS <> "" Then
        If Not dic.exists(numS) Then
          dic(numS) = 1 & "|" & addS
        Else
          y = Split(dic(numS), "|")(0)
          d = Split(dic(numS), "|")(1)
          y = y + 1
          dic(numS) = y & "|" & d & ", " & addS
        End If
      End If
    Next
  Next
  
  ReDim b(1 To dic.Count, 1 To 3)
  For Each ky In dic.keys
    y = Split(dic(ky), "|")(0)
    If y > 1 Then
      k = k + 1
      b(k, 1) = ky
      b(k, 2) = Split(dic(ky), "|")(0)
      b(k, 3) = Split(dic(ky), "|")(1)
    End If
  Next
    
  With Range(col & 1).Resize(dic.Count, 3)
    .Value = b
    .Sort Range(col & 1), xlAscending, Header:=xlNo
  End With
  
  Application.ScreenUpdating = False
End Sub

Prueba y nos comentas.

 

[dragonfire33]

Muchas gracias maestro Dante funciona

 

[dragonfire33]

Maestro Dante el código funciona, pero no me está arrojando los números que más se repiten en una columna ni la cantidad de veces en la otra columna

 

[DanteAmor]

El código pone 3 columnas: el número, la cantidad de veces que se repite y las celdas donde se encuentra el número:

Tal vez lo que necesitas es ordenas los datos por la cantidad de repetido de mayor a menor.
Solamente cambia esta línea:

.Sort Range(col & 1), xlAscending, Header:=xlNo

Por esta:

.Sort Cells(1, Columns(col).Column + 1), xlDescending, Header:=xlNo

 

[dragonfire33]

Listo Dante me arroja el número y la cantidad de repeticiones que tiene ese número en ese rango , pero ahora el problema es que me da la ubicación errónea de la celda donde está ese número , me está arrojando una celda más atrás de su ubicación ya lo probé con el buscador de excel y si el número está en la celda G3 el código me arroja que esta en F3 podremos solucionarlo graciss

 

[dragonfire33]

Listo Dante era mi rango de datos el problema pero ya lo he solucionado gracias a su comentario en la anterior pregunta