Macro buscar en Tabla B.xlsx y registrar info faltanten en la hoja "revisar" de Tabla A.xlsx
Se tiene dos archivos : Tabla A.xlsx y Tabla B.xlsx
Tabla A.xlsx Hoja1:
A B C
Codigo desde hasta
Codigo 1 1 2
Codigo 1 4 6
Codigo 2 0 1
............
Código N: nregistros o filas
Tabla B.xlsx : donde se encuentran las distancias según código y donde la macro debe buscar y sumar las distancias
Contenido de la Tabla B.xlsx Hoja1:
A B C D: ---------> Columnas
Codigo desde hasta distancia
Codigo 1 0 1 1010
Codigo 1 1 2 1005
Codigo 1 2 3 1100
Codigo 1 3 4 1000
Codigo 1 4 5 1000
Codigo 1 5 6 1035,59104
Codigo 1 6 7 2054,92586
Codigo 1 7 8 1010
Codigo 2 0 1 1000
Codigo 2 1 2 1000
............ ................ ....................
N registros o filas
Resultado :
En Tabla A.xlsx hoja: "Revisar"
Contenido de la hoja resultado llamada "Revisar": Colocar info faltante y las sumas de las distancias correspondientes
A B C D: ---------> Columnas
Codigo desde hasta distancia
Codigo 1 0 1 1010 : Es la Suma distancias de 0 a 1, este 1 es el 1 de la columna c (hasta) de Tabla B.xlsx
Codigo1 2 4 2100: Es la Suma distancias de 2 a 4, este 4 es el 4...
Codigo 1 6 8 3064,92586: Es la Suma distancias de 10 a 12, este 8 es el 8 ...
...............
Codigo 2 1 2 1000
...
Prueba la siguiente macro.
Nota: todos los datos empiezan en la celda A2 en todas las hojas.
Sub Registrar_Faltantes()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim a As Variant, b As Variant, c As Variant
Dim i As Long, j As Long, k As Long, m As Long
Dim existe As Boolean, existe2 As Boolean
'
Set sh1 = Workbooks("A.xlsx").Sheets("Hoja1")
Set sh3 = Workbooks("A.xlsx").Sheets("Revisar")
Set sh2 = Workbooks("B.xlsx").Sheets("Hoja1")
'
a = sh1.Range("A2", sh1.Range("C" & Rows.Count).End(3)).Value2
b = sh2.Range("A2", sh2.Range("D" & Rows.Count).End(3)).Value2
ReDim c(1 To UBound(b), 1 To 4)
'
For i = 1 To UBound(b)
existe = False
For j = 1 To UBound(a)
If b(i, 1) = a(j, 1) And b(i, 2) >= a(j, 2) And b(i, 2) < a(j, 3) Then
existe = True
Exit For
End If
Next
If existe = False Then
existe2 = False
For m = 1 To UBound(c)
If c(m, 3) = Empty Then Exit For
If b(i, 1) = c(m, 1) And b(i, 2) = c(m, 3) Then
existe2 = True
k = m
Exit For
End If
Next
If existe2 = True Then
c(m, 3) = b(i, 3)
c(m, 4) = c(m, 4) + b(i, 4)
Else
k = k + 1
c(k, 1) = b(i, 1)
c(k, 2) = b(i, 2)
c(k, 3) = b(i, 3)
c(k, 4) = b(i, 4)
End If
End If
Next
'
sh3.Range("A2").Resize(UBound(c), 4).Value = c
End Sub
