Macro que me pase una tabla dinámica a valores, rellene filas vacías, finalmente a subtotales.
Tengo una tabla dinámica como muestro en 2 fotos, para ver el inicio y final del archivo.
Foto1
Foto2
La muestro en partes por que es grande el archivo, seria posible que una macro haga lo siguiente:
- Copiar toda la tabla a valores, macro debe adecuarse al tamaño del archivo.
- Eliminar la ultima fila del total general, teniendo en cuenta que la TD es cambiante, n registros.
- Rellenar las filas en blanco de A hasta F con el dato que tiene cada columna. Debido a que, la TD solo te resume a una sola descripción.
- Finalmente, toda la tabla ponerla en subtotales, tiene que ordenarlo por OC y hacer la sumatoria del SUBTOTAL.
Lo hago manualmente y me queda si, espero pueda ser con una macro.
Pongo dos fotos para que se vea el inicio y el final del archivo, la macro debería adecuarse según tamaño de mi archivo.
Foto3
Foto4
Favor su soporte.
1 respuesta
Vamos a necesitar 2 hojas, la primera donde tienes la tabla dinámica, que según tu imagen empieza en la fila1, la segunda hoja es donde va a quedar el resultado.
Cambia los nombres de tus hojas en estas líneas de la macro:
Set h1 = Sheets("tabla dinamica") 'nombre hoja con la tabla dinámica
Set h2 = Sheets("Hoja6") 'nombre hoja para poner el resultadoLa macro:
Sub Rellenar()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("tabla dinamica") 'nombre hoja con la tabla dinámica
Set h2 = Sheets("Hoja6") 'nombre hoja para poner el resultado
'
h2.Cells.Clear
h2.Cells.RemoveSubtotal
h1.Cells.Copy
h2.Select
h2.Range("A1").PasteSpecial Paste:=xlPasteValues
u = h2.Range("J" & Rows.Count).End(xlUp).Row
h2.Rows(u).Delete
u = u - 1
h2.Range("A2:F" & u).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
h2.Range("A2:F" & u).Copy
h2.Range("A2").PasteSpecial Paste:=xlPasteValues
'
h2.Range("A1:J" & u).Subtotal GroupBy:=1, _
Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Hola Dante:
Cree otra hoja más para el resultado, cambie nombre a las hojas y al ejecutarla me sale este error.
¿Algo estaré haciendo mal?
foto5
foto6
foto7
Revisa que en la hoja "subtotales" no haya subtotales, elimina todos.
Cambia esta línea:
H2. Cells. RemoveSubtotal
Por estas:
On Error Resume Next h2.Cells.RemoveSubtotal On Error Goto 0
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
