Macro VBA que extraiga valores repetidos de dos rangos
Hola: buenas noches expertos
Me harían el grande favor de ayudarme con una macro, a manera de ejemplo adjunto la imagen, donde hay dos rangos de datos, el de la columna A:J y L:U, ambos rangos contienen números y en ocasiones hay valores repetidos en sus filas. En la columna W estaría el ejemplo de como seria el resultado de la macro, que consistiría en extraer los números repetidos en dicha fila y pegarlos a partir de esa columna, en el caso de la fila "2" se repiten en el rango los valores 780,033 y en la fila "3" solo el 297 y sucesivamente. Idea seria que al ejecutar la macro extrajera los datos y los pegara automáticamente hasta su ultima fila.
Muchísimas gracias ya que siempre he recibido una excelente ayuda por parte de ustedes.
Feliz noche
2 Respuestas
Parece que se puede hacer con fórmulas. Teniendo seleccionado el rango W2:AF2, pega esta fórmula en la barra de fórmulas:
=SI.ERROR(K.ESIMO.MAYOR(SI(NO(ESERROR(COINCIDIR(SI(A2:J2<>"";A2:I2);L2:U2;0)));A2:I2);COLUMNA()-22);"")
y termínala pulsando control mayúsculas entrada al mismo tiempo, ya que es obviamente matricial. Luego no hay más que copiarla y pegarla hacia abajo hasta donde haga falta.
En lugar de I2 es J2:
=si.error(k.esimo.mayor(si(no(eserror(coincidir(si(a2:j2<>"";a2:j2);l2:u2;0)));a2:j2);columna()-22);"")
Prueba la siguiente macro:
Sub ExtraerDuplicados()
Dim i As Long, j As Long, k As Long
Dim f As Range
For i = 2 To Range("A" & Rows.Count).End(3).Row
k = 23
For j = 1 To 10
If WorksheetFunction.CountIf(Range("L" & i & ":U" & i), Cells(i, j)) > 0 Then
Cells(i, k).Value = Cells(i, j)
k = k + 1
End If
Next
Next
End Sub
¡Gracias! Ne ha servido mucho la macro, solo que los rangos que tengo son de mil datos cada uno, y la macro demora mucho en arrojar los resultados pero lo hace exacto, no se si tal vez se pueda modificar algo para que haga más rápido o ya depende de los recursos del procesador de la pc.. pero agradezco mucho tu ayuda
Prueba el siguiente código.
Debe ser más rápido. Con 5,000 registros en cada tabla el resultado es inmediato.
Sub ExtraerDuplicados_2()
Dim dic As Object
Dim i As Long, j As Long, k As Long
Dim a As Variant, b As Variant
'
Set dic = CreateObject("Scripting.Dictionary")
a = Range("A2:U" & Range("A" & Rows.Count).End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 10)
'
For i = 1 To UBound(a, 1)
For j = 1 To 10
If a(i, j) <> "" Then dic(a(i, j)) = Empty
Next
k = 0
For j = 12 To 21
If dic.exists(a(i, j)) Then
k = k + 1
b(i, k) = a(i, j)
End If
Next
dic.RemoveAll
Next
'
Range("W2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Hola Dante,
Te cuento que la macro ejecuta a la velocidad de la F1, super rápida.. pero sabes algo, pero debo estar haciendo algo mal, porque al cambiarle los datos para ejecutarla en rangos más grandes, en algunas filas extrae los resultados y en otras no. y en algunas no lo hace completo.
En la imagen puedes ver el archivo donde la ejecuto y cada rango tiene un total de 1.000 columnas e hice otra tabla con fórmulas de "contar.si" para rectificar si la cantidad de números que arrojaba la macro estaba bien.. y así me di cuenta que no.
Voy a dejarte un enlace de mi drive para que mires el archivo. Ejecutes la macro o la revises.. porque no veo aquí la opción de adjuntar el archivo excel, creo que así nos ahorramos tiempo y lo revisas más fácil..
Si deseas que abra otra pregunta lo hago, o si puedes revisarlo quedo agradecido igualmente.
Muy contento con tu ayuda,, espero sea fácil de solucionar
Este es el link
https://drive.google.com/drive/folders/1h9pjRsX2Y7NEFhNyuqSumxKX8Au43iZ2?usp=sharing
Muchas gracias Dante
Debes indicar donde empieza y termina cada bloque de columnas:
Sub ExtraerDuplicados_2()
Dim dic As Object
Dim i As Long, j As Long, k As Long
Dim a As Variant, b As Variant
'
Set dic = CreateObject("Scripting.Dictionary")
a = Range("A2:BXY" & Range("A" & Rows.Count).End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 10)
'
For i = 1 To UBound(a, 1)
For j = 1 To 1000
If a(i, j) <> "" Then dic(a(i, j)) = Empty
Next
k = 0
For j = 1002 To 2001
If dic.exists(a(i, j)) Then
k = k + 1
b(i, k) = a(i, j)
End If
Next
dic.RemoveAll
Next
'
Range("BYA2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub