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