Crear una hoja x cada subtotal

He escrito el siguiente código, que creo que hace más o menos lo que necesitas:


Sub prueba()
Dim rngV As Range, rngA As Range, wksH As Worksheet

With Worksheets("Hoja1") 'Hoja donde están los subtotales
.Outline.ShowLevels RowLevels:=2
Set rngV = .[A1].SpecialCells(xlCellTypeVisible)
For Each rngA In rngV.Areas
If rngA.Row <> 1 Then 'Se Supone que la fila 1 es de títulos
Set wksH = Worksheets.Add(, Worksheets(.Parent.Worksheets.Count))
wksH.Name = Replace(.Range("A" & rngA.Row), "Total ", "")
.Rows(1).Copy Destination:=wksH.[A1] 'Copiar la fila de títulos a la nueva hoja
.Range(Replace(Right(.Range("B" & rngA.Row).Formula, Len(.Range("B" & rngA.Row).Formula) - InStr(.Range("B" & rngA.Row).Formula, ",")), ")", "")).EntireRow.Copy Destination:=wksH.[A2]
wksH.Cells.RemoveSubtotal
End If
Next rngA
End With

Set wksH = Nothing
Set rngA = Nothing
Set rngV = Nothing
End Sub


pero el problema es que el código exacto dependerá de cómo tengas los datos, así que he subido un ejemplo con el código funcionando a http://www.excelsp.com/ejemplos/eje...41116a.xls para que puedas adaptarlo.

Tendrás que descargar el libro porque el código no funcionará si se intenta ejecutar desde Internet Explorer.
Un saludo.


Fernando Arroyo
MS MVP - Excel



"BLACIO" escribió en el mensaje news:

Saludos a toda la comunidad
>>Tengo una base de datos de un tamaño considerable, y hago subtotales por cada cuenta (aproximadamente 150 cuentas),
>>Existe la posibilidad de crear una hoja por cada subtotal o cuenta, de manera sistematizada???
>si la hay me va hacer de mucha ayuda
de antemando muchas gracias

Fernando Arroyo, Muchisimas gracias "Eres mi Idolo"
Funciono bastante bien

a toda la comunidad... Estoy seguro que les puede ser de gran utilidad

Un saludo... desde México D. F.

"Fernando Arroyo" escribió:

He escrito el siguiente código, que creo que hace más o menos lo que necesitas:


Sub prueba()
Dim rngV As Range, rngA As Range, wksH As Worksheet

With Worksheets("Hoja1") 'Hoja donde están los subtotales
.Outline.ShowLevels RowLevels:=2
Set rngV = .[A1].SpecialCells(xlCellTypeVisible)
For Each rngA In rngV.Areas
If rngA.Row <> 1 Then 'Se Supone que la fila 1 es de títulos
Set wksH = Worksheets.Add(, Worksheets(.Parent.Worksheets.Count))
wksH.Name = Replace(.Range("A" & rngA.Row), "Total ", "")
.Rows(1).Copy Destination:=wksH.[A1] 'Copiar la fila de títulos a la nueva hoja
.Range(Replace(Right(.Range("B" & rngA.Row).Formula, Len(.Range("B" & rngA.Row).Formula) - InStr(.Range("B" & rngA.Row).Formula, ",")), ")", "")).EntireRow.Copy Destination:=wksH.[A2]
wksH.Cells.RemoveSubtotal
End If
Next rngA
End With

Set wksH = Nothing
Set rngA = Nothing
Set rngV = Nothing
End Sub


pero el problema es que el código exacto dependerá de cómo tengas los datos, así que he subido un ejemplo con el código funcionando a http://www.excelsp.com/ejemplos/eje...41116a.xls para que puedas adaptarlo.

Tendrás que descargar el libro porque el código no funcionará si se intenta ejecutar desde Internet Explorer.
Un saludo.


Fernando Arroyo
MS MVP - Excel



"BLACIO" escribió en el mensaje news:
> Saludos a toda la comunidad
> >>Tengo una base de datos de un tamaño considerable, y hago subtotales por cada cuenta (aproximadamente 150 cuentas),
> >>Existe la posibilidad de crear una hoja por cada subtotal o cuenta, de manera sistematizada???
> >si la hay me va hacer de mucha ayuda
> de antemando muchas gracias

"BLACIO" escribió en el mensaje news:

Fernando Arroyo, Muchisimas gracias "Eres mi Idolo"
Funciono bastante bien
>a toda la comunidad... Estoy seguro que les puede ser de gran utilidad
Un saludo... desde México D. F.

Me alegra saber que te ha servido :-)

He visto que se me olvidó poner las instrucciones para evitar el refresco de la pantalla (conviene evitarlo sobre todo si se ejecuta el código desde la hoja). El código quedaría, por lo tanto, así:

Sub prueba()
Dim rngV As Range, rngA As Range, wksH As Worksheet

Application.ScreenUpdating = False

With Worksheets("Hoja1") 'Hoja donde están los subtotales
.Outline.ShowLevels RowLevels:=2
Set rngV = .[A1].SpecialCells(xlCellTypeVisible)
For Each rngA In rngV.Areas
If rngA.Row <> 1 Then 'Se Supone que la fila 1 es de títulos
Set wksH = Worksheets.Add(, Worksheets(Parent.Worksheets.Count))
wksH.Name = Replace(.Range("A" & rngA.Row), "Total ", "")
.Rows(1).Copy Destination:=wksH.[A1] 'Copiar la fila de títulos a la nueva hoja
.Range(Replace(Right(.Range("B" & rngA.Row).Formula, Len(.Range("B" & rngA.Row).Formula) - InStr(.Range("B" & rngA.Row).Formula, ",")), ")", "")).EntireRow.Copy Destination:=wksH.[A2]
wksH.Cells.RemoveSubtotal
End If
Next rngA
End With

Application.ScreenUpdating = True

Set wksH = Nothing
Set rngA = Nothing
Set rngV = Nothing
End Sub


Un saludo.


Fernando Arroyo
MS MVP - Excel