Para KL

Hola Oscar,

Espero esto te ayude a entender mejor el macro.

Saludos,
KL

'--Inicio Codigo
Sub Union()
'Declaramos las variables
Dim Est As Variant, Dest As Variant
Dim pt As PivotTable, pf As PivotField
Dim rng As Range, DestRng As Range

'Creamos la matriz con los nombres de
'items cuyos datos queremos extraer.
Est = Array("Cancelado", "Asignado", "En espera", _
"En atencion", "Registro", "Resuelto")

'Creamos la matriz que contiene la ultima
'celda del rango a donde vamos a copiar
'los datos encontrados.
Dest = Array("B58", "B77", "B77", "B77", "B136", "B136")

'Creamos la variable para nuestra tabla
'dinamica para no tener que cargar con
'el nombre completo atraves del codigo.
Set pt = Sheets("Hoja9") _
.PivotTables("Tabla dinámica3")

'Por la misma razon que antes, creamos
'la variable para el campo en el que
'vamos a buscar nuestros items.
Set pf = pt.PivotFields("ESTATU")

'Borramos la informacion anterior
'de los rangos de destino.
Sheets("Reporte Admon 1-1-04"). _
Range("B50:C58,B62:C77,B81:C136").ClearContents

'Empezamos el bucle que repite las
'operaciones de abajo para cada uno
'de los miembros de la matriz que
'habiamos creado para los nombres de
'items a buscar.
For i = LBound(Est) To UBound(Est)

'Si el nombre de item vigente
'[Est(i)] no se encuentra en la tabla
'el trozo de codigo mas abajo fallara.
'Para evitar las interrupciones usamos
'la siguiente linea:
On Error Resume Next

'Creamos la variable para el rango que
'contiene el item buscado. Este rango
'Se compone del rango de etiquetas, el de
'los datos y del de los totales (este ultimo
'no es aplicable en el caso q nos concierne)
'Asi que obtenemos el rango de la interseccion
'del rango de toda la tabla (ancho) y el
'de todas las filas del campo encontrado (alto)
Set rng = Intersect(pt.TableRange1, _
pf.PivotItems(Est(i)).DataRange.EntireRow)

'Volvemos a aceptar interrupciones por error
On Error GoTo 0

'Si, como hemos dicho antes, no se encontrara
'el item buscado, fallaria la creacion de la
'variable del rango a copiar (rng) y al intentar
'copiarlo se produceria un error. Por eso
'primero comprobamos si se ha asignado algun
'rango a la variable rng:
If Not rng Is Nothing Then

'Modificamos las dimensiones de rng
'a fin de excluir el nombre del Item y
'dejar solo el nombre del Subitem y el
'dato correspondiente. Para ello:
'desplazamos todo el rango una columna
'a la derecha (Offset) y quitamos la
'ultima columna (Resize).
Set rng = rng.Offset(0, 1). _
Resize(rng.Rows.Count, rng.Columns.Count - 1)

'Creamos el rango a donde vamos a pegar
'los datos copiados. Primero buscamos la
'primera celda vacia por debajo del titulo
'de la primera columna de la tabla de destino.
'La obtenemos escaneando las celdas por encima
'del nombre de celda correspondiente a cada
'uno de los nombres de item de la tabla dinamica.
'Esas celdas la habiamos indicado en nuestra
'segunda matriz (Dest).
Set DestRng = Sheets("Reporte Admon 1-1-04") _
.Range(Dest(i)).End(xlUp).Offset(1, 0)

'Ahora modificamos las dimensiones del rango
'de destino (DestRng) aumentando el numero de
'filas y columnas hasta los mismos numeros que
'los del rango copiado (rng). Esto lo hacemos
'usando la funcion Resize y como parametros
'el numero de filas y el de columnas del rango
'copiado. Al mismo tiempo asignamos los valores
'de rng al DestRng, o sea DestRng.Value=rng.Value
With DestRng
.Resize(rng.Rows.Count, rng.Columns.Count) _
.Value = rng.Value
End With
End If

'Borramos los rangos creados en cada uno de
'los ciclos del bucle para que no interfieran
'con el ciclo siguiente.
Set rng = Nothing
Set DestRng = Nothing

'Pasamos al siguiente nombre de Item de la
'matriz Est.
Next i
End Sub
'--Fin Codigo

Ok. KL

Mil gracias por la explicacion, mi comprension de como
funciona se ha incrementado en un rango de A1 a K100,
jejejeje, ahora se cuento me falta para llenar mi hoja de
calculo, de cosas aprendidas

Un infinito agradecimiento, genio :)

Hola Oscar,

Espero esto te ayude a entender mejor el macro.

Saludos,
KL

'--Inicio Codigo
Sub Union()
'Declaramos las variables
Dim Est As Variant, Dest As Variant
Dim pt As PivotTable, pf As PivotField
Dim rng As Range, DestRng As Range

'Creamos la matriz con los nombres de
'items cuyos datos queremos extraer.
Est = Array("Cancelado", "Asignado", "En espera", _
"En atencion", "Registro", "Resuelto")

'Creamos la matriz que contiene la ultima
'celda del rango a donde vamos a copiar
'los datos encontrados.
Dest = Array

("B58", "B77", "B77", "B77", "B136", "B136")

'Creamos la variable para nuestra tabla
'dinamica para no tener que cargar con
'el nombre completo atraves del codigo.
Set pt = Sheets("Hoja9") _
.PivotTables("Tabla dinámica3")

'Por la misma razon que antes, creamos
'la variable para el campo en el que
'vamos a buscar nuestros items.
Set pf = pt.PivotFields("ESTATU")

'Borramos la informacion anterior
'de los rangos de destino.
Sheets("Reporte Admon 1-1-04"). _
Range("B50:C58,B62:C77,B81:C136").ClearContents

'Empezamos el bucle que repite las
'operaciones de abajo para cada uno
'de los miembros de la matriz que
'habiamos creado para los nombres de
'items a buscar.
For i = LBound(Est) To UBound(Est)

'Si el nombre de item vigente
'[Est(i)] no se encuentra en la tabla
'el trozo de codigo mas abajo fallara.
'Para evitar las interrupciones usamos
'la siguiente linea:
On Error Resume Next

'Creamos la variable para el rango que
'contiene el item buscado. Este rango
'Se compone del rango de etiquetas, el de
'los datos y del de los totales (este ultimo
'no es aplicable en el caso q nos concierne)
'Asi que obtenemos el rango de la interseccion
'del rango de toda la tabla (ancho) y el
'de todas las filas del campo encontrado (alto)
Set rng = Intersect(pt.TableRange1, _
pf.PivotItems(Est(i)).DataRange.EntireRow)

'Volvemos a aceptar interrupciones por error
On Error GoTo 0

'Si, como hemos dicho antes, no se encontrara
'el item buscado, fallaria la creacion de la
'variable del rango a copiar (rng) y al intentar
'copiarlo se produceria un error. Por eso
'primero comprobamos si se ha asignado algun
'rango a la variable rng:
If Not rng Is Nothing Then

'Modificamos las dimensiones de rng
'a fin de excluir el nombre del Item y
'dejar solo el nombre del Subitem y el
'dato correspondiente. Para ello:
'desplazamos todo el rango una columna
'a la derecha (Offset) y quitamos la
'ultima columna (Resize).
Set rng = rng.Offset(0, 1). _
Resize(rng.Rows.Count, rng.Columns.Count -

1)

'Creamos el rango a donde vamos a pegar
'los datos copiados. Primero buscamos la
'primera celda vacia por debajo del titulo
'de la primera columna de la tabla de destino.
'La obtenemos escaneando las celdas por encima
'del nombre de celda correspondiente a cada
'uno de los nombres de item de la tabla

dinamica.

'Esas celdas la habiamos indicado en nuestra
'segunda matriz (Dest).
Set DestRng = Sheets("Reporte Admon 1-1-04") _
.Range(Dest(i)).End(xlUp).Offset(1, 0)

'Ahora modificamos las dimensiones del rango
'de destino (DestRng) aumentando el numero de
'filas y columnas hasta los mismos numeros que
'los del rango copiado (rng). Esto lo hacemos
'usando la funcion Resize y como parametros
'el numero de filas y el de columnas del rango
'copiado. Al mismo tiempo asignamos los

valores

'de rng al DestRng, o sea

DestRng.Value=rng.Value

With DestRng
.Resize(rng.Rows.Count,

rng.Columns.Count) _

.Value = rng.Value
End With
End If

'Borramos los rangos creados en cada uno de
'los ciclos del bucle para que no interfieran
'con el ciclo siguiente.
Set rng = Nothing
Set DestRng = Nothing

'Pasamos al siguiente nombre de Item de la
'matriz Est.
Next i
End Sub
'--Fin Codigo


.