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

Respuesta
1

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);"")
Respuesta
1

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas