Cortar Filas con valores duplicados en Columnas y pegar en Nueva Hoja, dejar solo los valores Únicos.
Necesito realizar una fórmula o macro para
1- Identificar los valores duplicados en POR columna
2- Una vez identificados los valores duplicados de POR columna, cortar las filas que contengan los valores duplicados y pegarlos en una nueva hoja. De lo contrario solo eliminar los valores duplicados y dejar solo los únicos.
2 respuestas
Respuesta de Dante Amor
2
Te anexo la macro, realiza los siguientes cambios en la macro.
Cambia "Hoja4" por el nombre de tu hoja con datos
Cambia "Hoja5" par el nombre de tu hoja con resultados
Si quieres los registros únicos en la "Hoja5" deja el "1" en esta línea
h1.Range("A1:D" & u).AutoFilter Field:=4, Criteria1:="1"Si quieres los duplicados en la "Hoja5", entonces pon ">1"
h1.Range("A1:D" & u).AutoFilter Field:=4, Criteria1:=">1"La macro:
Sub Copiar_Unicos()
'Por.Dante Amor
'
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja4") 'hoja con datos
Set h2 = Sheets("Hoja5") 'hoja resultado
h2.Cells.Clear
'
u = h1.Range("B" & Rows.Count).End(xlUp).Row
h1.Range("D2:D" & u).FormulaR1C1 = "=COUNTIF(R2C2:R" & u & "C2,RC[-2])"
h1.Range("A1:D" & u).AutoFilter Field:=4, Criteria1:="1"
h1.Columns("A:C").Copy h2.[A1]
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h1.Columns("D").Clear
Application.ScreenUpdating = True
MsgBox "fin"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Respuesta de James Bond
1
Prueba con esta macro
Sub copiar()
Dim unicos As New Collection
Set h2 = Worksheets("hoja2")
Set datos = Range("a1").CurrentRegion
h2.Cells.Clear
With datos
.Sort key1:=Range(.Columns(2).Address), order1:=xlAscending, Header:=True
For j = 2 To .Rows.Count
factura = .Cells(j, 2)
On Error Resume Next: unicos.Add factura, CStr(factura): On Error GoTo 0
Next j
For i = 1 To unicos.Count
factura = unicos.Item(i)
cuenta = WorksheetFunction.CountIf(.Columns(2), factura)
fila = WorksheetFunction.Match(factura, .Columns(2), 0)
If cuenta > 1 Then
Set destino = h2.Range("a2").CurrentRegion
If destino.Rows.Count = 1 And destino.Columns.Count = 1 Then
destino.Resize(cuenta, .Columns.Count).Value = .Rows(fila).Resize(cuenta).Value
Else
destino.Rows(destino.Rows.Count + 1).Resize(cuenta, .Columns.Count).Value _
= .Rows(fila).Resize(cuenta).Value
End If
.Rows(fila).Resize(cuenta).EntireRow.Delete
End If
Next i
On Error Resume Next
destino.Rows(0).Value = .Rows(1).Value
On Error GoTo 0
End With
End Sub