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
...

1 respuesta

Respuesta
2

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas