Macro para encontrar duplicados en lista
-----
--
Buena noche
Podrian ayudarme con esta macro porfa
Necesito encontrar los duplicados de una lista que se encuentra en la cololumna A y que el resultado me lo coloque en la columna D (nombre de los articulos) y E (cantidad de veces que esta el articulo)
Y que empiece desde la fila 3 y no desde la 1 como aparece en el ejemplo
Gracias
-
-
-
3 Respuestas
¿Algo así es lo que buscas?
si la respuesta es si esta es la macro que ocupas
Sub busca_repetidos()
Dim c As Integer, f As Integer
Dim datos As Range, unicos As Range
Set datos = Range("a3").CurrentRegion
With datos
f = .Rows.Count: c = .Columns.Count
.Columns(c + 3).Clear
Set unicos = .Columns(c + 3).Resize(f, 2)
End With
With unicos
.Columns(1).Value = datos.Value
.RemoveDuplicates Columns:=1
.CurrentRegion.Select
Set unicos = Selection
For i = 1 To unicos.Rows.Count
texto = .Cells(i, 1)
.Cells(i, 2) = WorksheetFunction.CountIf(datos, texto)
Next i
.Sort key1:=Range(.Columns(2).Address), order1:=xlDescending
End With
End Sub
esta bien pero si hay filas en blanco no cuenta las filas siguientes a la fila en blanco
deberia saltarse la fila en blanco y seguir el conteo
La respuesta es simple no mencionaste que había filas en blanco ni tampoco lo mostraste en la imagen que subiste, la macro esta diseñada para datos sin espacios en blanco, ya aclarado el punto prueba esta macro, esta macro buscara la primera y la ultima fila con datos, quitara los espacios en blanco y luego hará la eliminación y el conteo.
Sub busca_repetidos()
Dim c As Integer, f As Integer
Dim datos As Range, unicos As Range
Dim primera As Integer
ultima = Selection.SpecialCells(xlCellTypeLastCell).Row
If WorksheetFunction.CountA(Cells) > 0 Then
primera = Cells.Find(What:="*", After:=[a1], _
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
End If
Set datos = Range("a" & primera & ":a" & ultima)
With datos
.Sort key1:=Range(.Address), order1:=xlAscending
f = .Rows.Count: c = .Columns.Count
.Columns(c + 3).Clear
Set unicos = .Columns(c + 3).Resize(f, 2)
End With
With unicos
.Columns(1).Value = datos.Value
.RemoveDuplicates Columns:=1
.CurrentRegion.Select
Set unicos = Selection
For i = 1 To unicos.Rows.Count
texto = .Cells(i, 1)
.Cells(i, 2) = WorksheetFunction.CountIf(datos, texto)
Next i
.Sort key1:=Range(.Columns(2).Address), order1:=xlDescending
End With
End Sub
Te anexo una macro, pon tus datos en la columna A, en la columna D te pondrá los únicos y en la E el conteo.
Sub Contar_Cup()
'Por.Dante Amor
u = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Copy Range("D1")
ActiveSheet.Range("D1:D" & u).RemoveDuplicates Columns:=1, Header:=xlNo
With Range("E1:E" & Range("D" & Rows.Count).End(xlUp).Row)
.FormulaR1C1 = "=COUNTIF(RC[-4]:R[6]C[-4],RC[-1])"
.Value = .Value
End With
End Sub
