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 respuestas
Respuesta de James Bond
3
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:
- Re ordena los datos de la Hoja1 lo cual no debe hacer
- 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)
- El rango en el cual evalúa es variable, no fijo (el R150 lo puse como ejemplo solamente)
- Se puede cambiar la columna B por la C , en cuanto a donde busca el registro repetido
- 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
Respuesta de Mario Rodríguez
2
:)
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 SubSaludos, Mario (Cacho) Rodríguez.
:)
.