Macro para revisar duplicados y copiar

Ando en busca de una macro que revise la HOJA 1 (Rango de ejemplo: A1:R150 con la fila 1 como títulos) y evalúe si hay datos duplicados en la columna B de ese rango. Si encuentra duplicados, que copie las filas completas donde se encuentran y los pegue en la HOJA 2 (con los mismos títulos de la HOJA 1) pero añadiendo la fila en la cual se encuentran esos duplicados.

2

2 Respuestas

193.975 pts. Si de mis mayores gustos, mis disgustos han nacido,...

Prueba esta macro

Sub copia_duplicados()
Dim funcion As WorksheetFunction
Set datos = Range("a2:r150")
Set funcion = WorksheetFunction
Set h2 = Worksheets("hoja2")
h2.Cells.Clear
With datos
    r = .Rows.Count: c = .Columns.Count
    .Sort key1:=Range(.Columns(2).Address), Order1:=xlAscending
    Set tabla = .Columns(c + 3).Resize(r, 1)
    With tabla
        .Value = datos.Columns(2).Value
        .RemoveDuplicates Columns:=1
        Set tabla = .CurrentRegion
        r2 = .Rows.Count
        For i = 1 To r2
            dato = .Cells(i, 1)
            cuenta = funcion.CountIf(datos.Columns(2), dato)
            If cuenta = 1 Then GoTo sig
            fila = funcion.Match(dato, datos.Columns(2), 0)
            Set origen = datos.Rows(fila).Resize(cuenta)
            Set tabla2 = Worksheets("hoja2").Range("a1").CurrentRegion
            r3 = tabla2.Rows.Count
            tabla2.Rows(r3 + 1).Resize(origen.Rows.Count, c).Value = origen.Value
sig:
        Next i
        Set tabla2 = tabla2.CurrentRegion
        tabla2.Rows(1).Value = datos.Rows(0).Value
    End With
    Set tabla = Nothing: Set tabla2 = Nothing: Set datos = Nothing
    Set funcion = Nothing: Set h2 = Nothing
End With
End Sub

Estimado, muchas gracias, pero me presenta los siguientes problemas:

  1. Re ordena los datos de la Hoja1 lo cual no debe hacer
  2. Al llevarse los datos a la Hoja2 se los lleva con fila de títulos y todo, y lo idea es que solo se lleve los datos, no la fila 1 en la cual se encuentren los títulos (ideal que empiece a pegar en Hoja2 desde la celda A2)
  3. El rango en el cual evalúa es variable, no fijo (el R150 lo puse como ejemplo solamente)
  4. Se puede cambiar la columna B por la C , en cuanto a donde busca el registro repetido
  5. No pone el numero de la linea en la cual se encuentran los registros repetidos.

Muchas gracias!

Prueba esta macro

Sub copia_duplicados2()
Dim funcion As WorksheetFunction
Set h1 = Worksheets("hoja1")
Set h2 = Worksheets("hoja2")
h2.Cells.Clear
Set datos = h1.Range("a1").CurrentRegion
Set funcion = WorksheetFunction
With datos
    r = .Rows.Count: c = .Columns.Count
    Set datos = .Rows(2).Resize(r - 1, c)
    .Columns(1).EntireColumn.Insert
    .Cells(1, 0) = 1
    .Cells(1, 0).AutoFill Destination:=h1.Range(.Cells(1, 0).Resize(r - 1, 1).Address), Type:=xlFillSeries
    Set datos = .CurrentRegion
    .Sort key1:=h1.Range("d:d"), order1:=xlAscending, Header:=xlYes
    .Columns(c + 3).Resize(r, 1).ClearContents
    Set tabla = .Columns(c + 3).Resize(r, 1)
    With tabla
        .Value = datos.Columns(4).Value
        .RemoveDuplicates Columns:=1
        Set tabla = .CurrentRegion
        r2 = .Rows.Count
        For i = 2 To r2
            dato = .Cells(i, 1)
            cuenta = funcion.CountIf(datos.Columns(4), dato)
            If cuenta > 1 Then
            fila = funcion.Match(dato, datos.Columns(4), 0)
            Set origen = datos.Rows(fila).Resize(cuenta, c)
            Set destino = h2.Range("a1").CurrentRegion
            rd = destino.Rows.Count
            destino.Rows(rd + 1).Resize(cuenta, c).Value = origen.Value
            End If
        Next i
        .ClearContents
    End With
    With destino
        Set destino = .Rows(2).Resize(destino.Rows.Count, destino.Columns.Count)
        .Sort key1:=h2.Range(.Columns(1).Address), order1:=xlAscending
        .EntireColumn.AutoFit
    End With
    .Sort key1:=h1.Range("a:a"), order1:=xlAscending, Header:=xlYes
    .Columns(1).EntireColumn.Delete
    Set destino = destino.CurrentRegion
End With
Set destino = Nothing: Set origen = Nothing: Set tabla = Nothing
Set datos = Nothing: Set funcion = Nothing: Set h1 = Nothing: Set h2 = Nothing
End Sub
72.775 pts.

:)

Hola! Jorge. Intenta con:

Sub evaluar_Repetidos()
Dim LR&, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Hoja 1"): Set ws2 = Sheets("Hoja 2")
Application.ScreenUpdating = False
ws2.Cells.Clear
LR = ws1.Cells(Rows.Count, "b").End(xlUp).Row
ws1.Range("a1:b" & LR).Insert xlShiftToRight
With ws1.Range("a1:a" & LR)
  .Formula = "=CountIf($d$1:$d$" & LR & ", d1)": .Value = .Value
  With .Offset(, 1)
    .Formula = "=row()": .Value = .Value
  End With
  .Cells(1, 2) = "_Fila_": ws1.Range("b1:t1").Copy ws2.[b1]
  ws2.[a2] = "=" & .Cells(2).Address(0, 0, external:=True) & ">1"
End With
ws1.Range("a1:t" & LR).AdvancedFilter 2, ws2.[a1:a2], ws2.[b1:t1]
With ws2.[a1].CurrentRegion
  .Sort ws2.[d1], xlAscending, Header:=xlYes
  .Columns("a").Delete xlShiftToLeft
  .Columns.AutoFit
End With
ws1.Range("a1:b" & LR).Delete xlShiftToLeft
Application.ScreenUpdating = True
MsgBox "Proceso terminado."
End Sub

Saludos, Mario (Cacho) Rodríguez.

:)

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas