Comparar dos listas y generar un listado único?

Para Dante Amor

De una pregunta anterior me he tomado la tarea de resolverla por si mismo, he avanzado algo, pero igual aún no tengo el resultado deseado. Lo que quiero es comparar dos listas de datos y generar una tercera lista con datos únicos a partir de un ID

resultado deseado

Sub Comparar2()
  Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    h1.Range("H4:L" & Rows.Count).ClearContents
    r = 1
    j = 4
    For i = 4 To h1.Range("B" & Rows.Count).End(xlUp).Row
        Set b = h1.Columns("B").Find(h1.Cells(i, "E"), lookat:=xlWhole)
        Set c = h1.Cells(i, "E")
          Set d = h1.Cells(i, "B")
        u2 = h1.Range("i" & Rows.Count).End(xlUp).Row + 1
            h1.Cells(u2, "H").Value = r
        If Not b Is Nothing Then
            h1.Cells(j, 9) = h1.Cells(b.Row, 2)
            h1.Cells(j, 10) = h1.Cells(b.Row, 3)
            h1.Cells(j, 11) = h1.Cells(c.Row, 6)
            End If
            If h1.Cells(d.Row, 2).Value <> h1.Cells(c.Row, 5).Value And h1.Cells(c.Row, 5).Value <> h1.Cells(d.Row, 2).Value Then
            h1.Cells(j, 9) = h1.Cells(d.Row, 2)
            h1.Cells(j, 10) = h1.Cells(d.Row, 3)
            h1.Cells(j, 9) = h1.Cells(c.Row, 5)
            h1.Cells(j, 11) = h1.Cells(c.Row, 6)
            End If
            r = r + 1
            j = j + 1
    Next
  Application.ScreenUpdating = True
End Sub

pero no logro obtener lo que deseo

1 Respuesta

Respuesta
4

Supongo que los datos en la columna B son únicos, es decir, en la misma columna B no hay datos repetidos.

Según tus ejemplos y tu macro.

Los datos de la lista 1 empiezan en la celda B4.

Los datos de la lista 2 empiezan en la celda E4.

Y los encabezados del resultado empiezan en la celda H3.

Si lo anterior es correcto, el resultado sería así:

El enfoque de la macro es diferente. Los cálculos se realizan en memoria, eso la hace más rápida:

Sub Comparar_dos_listas()
  Dim a As Variant, b As Variant, dic As Object
  Dim i As Long, v1 As Double, v2 As Double, v3 As Double
  '
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  '
  'ENTRADA DE VALORES
  a = Range("B4", Range("C" & Rows.Count).End(3)).Value2
  b = Range("E4", Range("F" & Rows.Count).End(3)).Value2
  Set dic = CreateObject("Scripting.Dictionary")
  '
  'PROCESO
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = a(i, 2) & "|" & 0 & "|" & a(i, 2)
  Next i
  For i = 1 To UBound(b, 1)
    If dic.exists(b(i, 1)) Then
      v1 = Split(dic(b(i, 1)), "|")(0)
      v2 = b(i, 2)
      v3 = v1 - v2
      dic(b(i, 1)) = v1 & "|" & v2 & "|" & v3
    Else
      dic(b(i, 1)) = 0 & "|" & b(i, 2) & "|" & -b(i, 2)
    End If
  Next i
  '
  'SALIDA
  With Range("H3")
    .Offset(1).Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.keys, dic.items))
    .Offset(1, 1).Resize(dic.Count).TextToColumns , 1, Other:=True, OtherChar:="|"
    .Resize(dic.Count + 1, 4).Sort Range(.Address), xlAscending, Header:=xlYes
  End With
  Application.ScreenUpdating = True
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas