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 Respuesta
Respuesta de Dante Amor
1
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 SubEsta 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 SubSal u dos
