Agregar condición al codigo

[dragonfire33]

Hola buenas noches, tengo el siguiente código del maestro @DanteAmor y me gustaría agregarle que también se cuente los números que comienzan en cero ya que al ejecutarlo me arroja los números desde 1000 en adelante
Gracias

Sub Repetid()
    col = "TK"
    '
    Application.ScreenUpdating = False
    Application.StatusBar = False
    c = Columns(col).Column
    Range(Cells(1, c), Cells(1, c + 2)).EntireColumn.ClearContents
    cuenta = Range("A1:SZ217").SpecialCells(xlCellTypeConstants, 23).Count
    m = 1
    For Each n In Range("A1:SZ217").SpecialCells(xlCellTypeConstants, 23)
        Application.StatusBar = "Paso 1, procesando celda: " & m & " de: " & cuenta
        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
        m = m + 1
    Next
    m = 1
    For i = u To 1 Step -1
        Application.StatusBar = "Paso 2, procesando celda: " & m & " de: " & u
        If Cells(i, c + 1) = 1 Then
            Range(Cells(i, c), Cells(i, c + 2)).Delete Shift:=xlUp
        End If
        m = m + 1
    Next
    '
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(Cells(1, c), Cells(u, c)), _
            SortOn:=xlSortOnValues, Order:=xlAscending, 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
    Application.StatusBar = False
    MsgBox "Fin"
End Sub

 

[DanteAmor]

Hola Dragon:

me gustaría agregarle que también se cuente los números que comienzan en cero

Si los números comienzan con 0, supongo que las celdas tienen formato texto. Por lo tanto, la columna TK también deberá tener formato texto para que el número también se almacene con 0's a la izquierda.

Ahora la macro es más rápida ya que maneja un dictionary, el proceso para las más de 100 mil celdas es de 4 segundos.

Nota: Si vas a cambiar el rango "A1:SZ217", deberás ajustar esta línea: addS = Cells(i, j).Address(0, 0) , porque tu rango empieza en la celda A1, significa que empieza en la fila 1, columna 1. Entonces en la macro: i empieza con 1 y j empieza con 1. Entonces, si cambias el rango inicial, deberás aumentar i + el número de filas que aumentes y j + el número de columnas que aumentes. Por ejemplo si tu rango cambia a "C2:B218", entonces aumentaste 1 fila y 2 columnas, la línea quedaría: addS = Cells(i + 1, j + 2).Address(0, 0)


En la macro también agregué el StatusBar para que observes en cuál paso va la macro:

Sub Repetid_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 = "TK"
  a = Range("A1:SZ217").Value2
  Range(col & 1).Resize(1, 3).EntireColumn.ClearContents
  Range(col & 1).EntireColumn.NumberFormat = "@"
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  Application.StatusBar = "Paso 1: Procesando celdas"
  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
  
  Application.StatusBar = "Paso 2: Eliminando números con conteo = 1"
  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
    
  Application.StatusBar = "Paso 3: Ordenando datos"
  With Range(col & 1).Resize(dic.Count, 3)
    .Value = b
    .Sort Range(col & 1), xlAscending, Header:=xlNo
  End With
  
  Application.ScreenUpdating = False
  Application.StatusBar = ""
End Sub

Saludos
Dante Amor

 

[dragonfire33]

Muchas gracias maestro Dante por el código