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

2 respuestas

Respuesta
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
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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas