Macro para que no borre encabezado y sea más rápida

Dante Amor buenos días, favor su apoyo para que la macro mencionada no borre el encabezado (la primera fila), y finalmente si se puede hacer más rápida ya que se demora en validar mucho las 40 mil filas.

Agradezco de antemano por las enseñanzas

Sub Unicos_Duplicados()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Por Dante Amor
    'cuenta unicos y duplicados
    '
    u = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To u
        valor = Cells(i, "A").Value
        If valor > 0 Then
            cuenta = Application.WorksheetFunction.CountIf(Range(Cells(1, "A"), Cells(u, "A")), valor)
            If cuenta = 1 Then
                Cells(i, "B").Value = 1
            Else
                Cells(i, "B").Value = 2
            End If
        End If
    Next
    MsgBox "fin"
Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub
1

1 Respuesta

4.531.300 pts. Sancho, si los perros ladran ...

Te anexo la macro actualizada, para 40 mil registros, tarda 3 minutos.

Sub Unicos_Duplicados_2()
'Por Dante Amor
    'cuenta unicos y duplicados
    '
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.StatusBar = False
    '
    u = Range("A" & Rows.Count).End(xlUp).Row
    Set rango = Range("A2:A" & u)
    rango.Offset(0, 1).Value = 1
    For i = 1 To u
        Application.StatusBar = "Procesando : " & i & " de : " & u
        valor = rango.Cells(i, 1)
        cuenta = Application.WorksheetFunction.CountIf(rango, valor)
        If cuenta > 1 Then
            rango.Cells(i, "B").Value = 2
        End If
    Next
    '
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    MsgBox "fin"
End Sub

Esta macro tarda menos de un minuto.

Nota: No apagues ni los cálculos ni la actualización de pantalla

Sub Unicos_Duplicados_3()
'Por Dante Amor
    'cuenta unicos y duplicados
    u = Range("A" & Rows.Count).End(xlUp).Row
    With Range("B2:B" & u)
        .FormulaR1C1 = "=IF(COUNTIF(R3C1:R" & u & "C1,RC1)>1,2,1)"
        .Value = .Value
    End With
    MsgBox "Fin"
End Sub

Sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas