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 Subpero no logro obtener lo que deseo
1 Respuesta
Respuesta de Dante Amor
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
