Cuantificación de registros dependiendo de dos variables en múltiples pestañas de Excel.

En mi libro llamado "TRANSMITTAL", tengo una pestaña llamada "Control de Revisiones", aquí es donde vacío la información de los reportes (pestañas nuevas) que se van agregando en este mismo libro, el formato de cada reporte es un templete predefinido y se realiza de forma numérica consecutiva, para cada reporte.

De estos reportes, me interesa obtener: 01.- La cantidad de registros que tiene cada uno de los reportes (Pestañas), dependiendo del tipo de registro que son y la revisión en la que se encuentran.

El tipo de registro ( o ID ) se encuentra a partir de la celda C37 en adelante en cada uno de los reportes, se pueden localizar fácilmente ya que siempre se encontrara entre dos guiones medios y normalmente es un numero y una letra. Ejemp: "-1A-", "-1B-", "-1C-" y pueden llegar a ser desde 1 hasta 200+ registros por reporte.

La revisión se localiza en la celda F37 en adelante y es la revisión para cada registro de la columna C. Estos definen en que revisión se encuentra el registro y siempre serán: R0, R1, R2, RZ. No importa si tengo 50 registros -1A-, los que marcan la diferencia son las revisiones, para el conteo de registros.

Esta información deberá ser vaciada en la pestaña "Control de Revisiones". En la columna "Q" a partir de la fila 3, tengo todos los ID de los registros y en las columnas ES ( R0 ), T ( R1 ), U ( R2 ), V ( RZ ), las revisiones a las que pertenecen, de igual manera a partir de la fila 3, con su ID correspondiente. 1A - fila 3, 1B fila 4, 1C fila 5... Etc.

La intención es que la macro busque dentro de todos los reportes ( pestañas ) todos los registros similares ( ID's ) con sus revisiones y los vaya sumando en su celda correspondiente dentro de la pestaña "Control de Revisiones" para obtener un conteo total de registros de forma automática, ya que estos pueden llegar a ser hasta 2000 reportes con "n" cantidad de registros en cada uno de ellos. El archivo se encuentra disponible si necesario enviarlo por correo.

1 respuesta

Respuesta
1

Prueba la siguiente macro:

Sub Control_de_Revisiones_Conteo_Revisiones()
'Por Dante Amor
  Dim sh As Worksheet, sh1 As Worksheet
  Dim i As Long, j As Long, k As Long, n As Long
  Dim c As Range, rng As Range
  Dim dic1 As Object, dic2 As Object
  Dim nId As Variant, b As Variant, datos As Variant
  Dim rev As String
  '
  Set sh1 = Sheets("Control de Revisiones")
  sh1.Range("S3:V" & Rows.Count).ClearContents
  Set rng = sh1.Range("S2:V2")
  ReDim b(1 To sh1.Range("Q" & Rows.Count).End(3).Row - 2, 1 To rng.Count)
  '
  Set dic1 = CreateObject("Scripting.Dictionary")
  n = 0
  For Each c In sh1.Range("Q3", sh1.Range("Q" & Rows.Count).End(3))
    n = n + 1
    dic1(c.Value) = n
  Next
  Set dic2 = CreateObject("Scripting.Dictionary")
  n = 0
  For Each c In rng
    n = n + 1
    dic2(c.Value) = n
  Next
  '
  For Each sh In Sheets
    Select Case LCase(sh.Name)
      Case LCase(sh1.Name), LCase("FORMATO")
      Case Else
        i = 37
        Do While True
          datos = Split(sh.Range("C" & i).Value, "-")
          If UBound(datos) > 1 Then
            nId = datos(1)
            j = dic1(nId)
            k = dic2(sh.Range("F" & i).Value)
            If j > 0 And k > 0 Then
              b(j, k) = b(j, k) + 1
            End If
          Else
            Exit Do
          End If
          i = i + 1
        Loop
      End Select
  Next sh
  sh1.Range("S3").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Dante,

La macro funciona excelente, solo tuve un detalle, al momento que busca las revisiones de la columna F en cada uno de los reportes, el ciclo termina cuando ya no encuentra la siguiente revisión y mi problema es que tengo encabezados y pies de páginas para dividir las hojas.

Si elimino, los siguientes encabezados y pies de páginas, de las demás hojas, si me realiza el calculo como debe ser. En este punto lo pudiera hacer, no hay problema por eso, sin embargo, habrá alguna manera de que lo cuantifique sin necesidad de eliminar esas filas!?

 De la siguiente manera si lo realizo. 

Prueba lo siguiente:

Sub Control_de_Revisiones_Conteo_Revisiones()
'Por Dante Amor
  Dim sh As Worksheet, sh1 As Worksheet
  Dim i As Long, j As Long, k As Long, n As Long
  Dim c As Range, rng As Range
  Dim dic1 As Object, dic2 As Object
  Dim nId As Variant, b As Variant, datos As Variant
  Dim rev As String
  '
  Set sh1 = Sheets("Control de Revisiones")
  sh1.Range("S3:V" & Rows.Count).ClearContents
  Set rng = sh1.Range("S2:V2")
  ReDim b(1 To sh1.Range("Q" & Rows.Count).End(3).Row - 2, 1 To rng.Count)
  '
  Set dic1 = CreateObject("Scripting.Dictionary")
  n = 0
  For Each c In sh1.Range("Q3", sh1.Range("Q" & Rows.Count).End(3))
    n = n + 1
    dic1(c.Value) = n
  Next
  Set dic2 = CreateObject("Scripting.Dictionary")
  n = 0
  For Each c In rng
    n = n + 1
    dic2(c.Value) = n
  Next
  '
  For Each sh In Sheets
    Select Case LCase(sh.Name)
      Case LCase(sh1.Name), LCase("FORMATO")
      Case Else
        For i = 37 To sh.Range("C" & Rows.Count).End(3).Row
          datos = Split(sh.Range("C" & i).Value, "-")
          If UBound(datos) > 1 Then
            nId = datos(1)
            j = dic1(nId)
            k = dic2(sh.Range("F" & i).Value)
            If j > 0 And k > 0 Then
              b(j, k) = b(j, k) + 1
            End If
          End If
        Next
      End Select
  Next sh
  sh1.Range("S3").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas