Desduplicar sin perder datos excel vba
Con que función puedo desduplicar las celdas de excel sin perder los resultados de la derecha como muestro en las imágenes de abajo
Lo que necesito obtener, es que si la columna C tiene el mismo nombre; me quite el duplicado de abajo, suba el valor de la columna F y quede como en la imagen a continuación:
Se hacerlo en sql pero no en excel vba, alguien me puede ayudar.
No tengo ninguna función hecha porque no tengo la menor idea de como hacerlo.
1 Respuesta
Para la pregunta 1: los registros son variables entre 100 y 300
Para la pregunta 2: si existen celdas vacías en la columna c (ver imagen de abajo)
Para la pregunta 3: los duplicados pueden ser entre 50 y 100, dependiendo del numero de registros.
Mira, te dejo un ejemplo más claro de lo que necesito recorrer;
Es solo una muestra con 20 registros ya que de lo contrrio, no podrías ver la imagen, pero como te puedes dar cuenta los repetidos no son consecutivos sino que existen en diferentes celdas, eso depende de como los arroja el sistema cuando exportan el archivo.
Pero cuál sería la llave, ¿la columna B o la columna C?
Según tu ejemplo, si tomamos la columna C como llave, el registro 1 se empalmaría con el registro 11, tienes dos 1 en la misma columna E.
La llave lo más seguro es que sea la columna B ya que es el ID de los sitios, la columna C es el domicilio de los sitios. Y revisando, tienes razón, la columna B debe ser a llave para evitar que se empalmen los registros.
Prueba lo siguiente, pon tus datos en la Hoja1, los resultado quedarán en la Hoja2.
'
Sub Desduplicar()
'DECLARACIÓN DE VARIABLES
Dim sh1 As Worksheet, sh2 As Worksheet, dic As Object
Dim i As Long, j As Long, k As Long, lr As Long, lc As Long, m As Long
Dim a As Variant, b As Variant, existe As Boolean
'ENTRADA
Set sh1 = Sheets("Hoja1")
Set sh2 = Sheets("Hoja2")
Set dic = CreateObject("Scripting.Dictionary")
lr = sh1.Range("B" & Rows.Count).End(3).Row
lc = sh1.UsedRange.Columns(sh1.UsedRange.Columns.Count).Column
a = sh1.Range(sh1.Cells(1, 1), sh1.Cells(lr, lc)).Value2
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
sh2.Cells.ClearContents
'PROCESO
For i = 1 To UBound(a, 1)
If Not dic.exists(a(i, 2)) Then
j = j + 1
m = j
Else
m = Split(dic(a(i, 2)), "|")(0)
End If
'
existe = False
For k = 5 To UBound(a, 2)
If a(i, k) <> "" Then
existe = True
Exit For
End If
Next
'
If existe = True Then
dic(a(i, 2)) = m & "|" & a(i, k)
b(m, 1) = a(i, 1)
b(m, 2) = a(i, 2)
b(m, 3) = a(i, 3)
b(m, k) = a(i, k)
End If
Next
'SALIDA
sh2.Range("A1").Resize(lr, lc).Value = b
End Sub
¡Gracias! No tienes idea de cuanto te lo agradezco, funciona de maravilla y la verdad es que no se me ocurría como manejar el arreglo, excelente idea pasarlo a otra hoja. Gracias infinitas!
