Guardar hoja especifica de un libro en otro nuevo

Con una macro puedo guardar la hoja activa del libro en otro nuevo, pero el problema esta en que al guardar la hoja en otro libro, la guarda pero un poco más ancha que la original saliéndose de los margenes de impresión.

La macro es la siguiente

Option Explicit
'
Sub EXCELeINFOGuardarHojaComoArchivoNuevo()
'
'Declaramos las variables.
Dim VentanasProtegidas As Boolean
Dim EstructuraProtegida As Boolean
Dim NombreHoja As String
Dim Confirmacion As String
Dim NombreArchivo As String
Dim GuardarComo As Variant
Dim Extension As String
'
'En caso de error.
On Error GoTo ErrorHandler
'
'Validamos si la ventana o la estructura del archivo están protegidos.
VentanasProtegidas = ActiveWorkbook.ProtectWindows
EstructuraProtegida = ActiveWorkbook.ProtectStructure
'
'En caso de estar protegidas mostramos mensaje.
If VentanasProtegidas = True Or EstructuraProtegida = True Then
MsgBox "No se puede ejecutar el comando cuando la estructura del archivo está protegida.", _
vbExclamation, "EXCELeINFO"
Else
'
'Copiamos la hoja y guardamos.
NombreHoja = ActiveSheet.Name
Confirmacion = MsgBox("Desea guardar la hoja '" & NombreHoja & "' como archivo nuevo?", _
vbQuestion + vbYesNo, "EXCELeINFO")
Application.ScreenUpdating = False
If Confirmacion = vbYes Then
ActiveSheet.Select
ActiveSheet.Copy
NombreArchivo = ActiveWorkbook.Name
GuardarComo = Application.GetSaveAsFilename(InitialFileName:=NombreHoja, _
fileFilter:="Libro de Excel(*.xlsx), *.xlsx, Libro de Excel habilitado para macros(*.xlsm), *.xlsm, Libro de Excel 97-2003(*.xls), *.xls,CSV (delimitado por comas)(*.csv),*.csv", _
Title:="EXCELeINFO - guadar hoja activa como archivo nuevo.")
If GuardarComo = False Then
Workbooks(NombreArchivo).Close SaveChanges:=False
Else
With Application.WorksheetFunction
Extension = .Trim(Right(.Substitute(GuardarComo, ".", .Rept(" ", 500)), 500))
End With

Select Case Extension
Case Is = "xlsx"
ActiveWorkbook.SaveAs GuardarComo
Case Is = "xlsm"
ActiveWorkbook.SaveAs GuardarComo, xlOpenXMLWorkbookMacroEnabled
Case Is = "xls"
ActiveWorkbook.SaveAs GuardarComo, xlExcel8
Case Is = "csv"
ActiveWorkbook.SaveAs GuardarComo, xlCSV
Case Else
ActiveWorkbook.SaveAs GuardarComo
End Select
End If
Else
End If
'
End If
'

Exit Sub
'
'En caso de error mostramos un mensaje.
ErrorHandler:
MsgBox "Ha ocurrido un error: " & Err.Description, vbExclamation, "EXCELeINFO"
Workbooks(NombreArchivo).Close SaveChanges:=False
'
End Sub

1 respuesta

Respuesta
1

H o l a:

Tal vez se cambia el formato por cambiar la versión.

Pero prueba lo con lo siguiente, lo que hice fue grabar una macro obteniendo todos los parámetros de impresión de la hoja. Después estoy asignado cada parámetro de la hoja origen en la hoja destino; la prueba la hice cuando se guarda como xlsx, prueba con esa versión y después prueba con las demás.

Option Explicit
'
Sub EXCELeINFOGuardarHojaComoArchivoNuevo()
    '
    'Declaramos las variables.
    Dim VentanasProtegidas As Boolean
    Dim EstructuraProtegida As Boolean
    Dim NombreHoja As String
    Dim Confirmacion As String
    Dim NombreArchivo As String
    Dim GuardarComo As Variant
    Dim Extension As String
    Dim l1, l2, h1, h2
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.ActiveSheet
    'En caso de error.
    On Error GoTo ErrorHandler
    '
    'Validamos si la ventana o la estructura del archivo están protegidos.
    VentanasProtegidas = ActiveWorkbook.ProtectWindows
    EstructuraProtegida = ActiveWorkbook.ProtectStructure
    '
    'En caso de estar protegidas mostramos mensaje.
    If VentanasProtegidas = True Or EstructuraProtegida = True Then
        MsgBox "No se puede ejecutar el comando cuando la estructura del archivo está protegida.", _
        vbExclamation, "EXCELeINFO"
    Else
        '
        'Copiamos la hoja y guardamos.
        NombreHoja = ActiveSheet.Name
        Confirmacion = MsgBox("Desea guardar la hoja '" & NombreHoja & "' como archivo nuevo?", _
        vbQuestion + vbYesNo, "EXCELeINFO")
        Application.ScreenUpdating = False
        If Confirmacion = vbYes Then
            ActiveSheet.Select
            ActiveSheet.Copy
            Set l2 = ActiveWorkbook
            Set h2 = l2.ActiveSheet
            NombreArchivo = ActiveWorkbook.Name
            GuardarComo = Application.GetSaveAsFilename(InitialFileName:=NombreHoja, _
            fileFilter:="Libro de Excel(*.xlsx), *.xlsx, Libro de Excel habilitado para macros(*.xlsm), *.xlsm, Libro de Excel 97-2003(*.xls), *.xls,CSV (delimitado por comas)(*.csv),*.csv", _
            Title:="EXCELeINFO - guadar hoja activa como archivo nuevo.")
            If GuardarComo = False Then
                Workbooks(NombreArchivo).Close SaveChanges:=False
            Else
                With Application.WorksheetFunction
                    Extension = .Trim(Right(.Substitute(GuardarComo, ".", .Rept(" ", 500)), 500))
                End With
                Select Case Extension
                    Case Is = "xlsx"
                        Call ConfigurarPagina(h1, h2)
                        ActiveWorkbook.SaveAs GuardarComo
                    Case Is = "xlsm"
                        ActiveWorkbook.SaveAs GuardarComo, xlOpenXMLWorkbookMacroEnabled
                    Case Is = "xls"
                        ActiveWorkbook.SaveAs GuardarComo, xlExcel8
                    Case Is = "csv"
                        ActiveWorkbook.SaveAs GuardarComo, xlCSV
                    Case Else
                        ActiveWorkbook.SaveAs GuardarComo
                End Select
            End If
        Else
        End If
        '
    End If
    '
    Exit Sub
    '
    'En caso de error mostramos un mensaje.
ErrorHandler:
    MsgBox "Ha ocurrido un error: " & Err.Description, vbExclamation, "EXCELeINFO"
    Workbooks(NombreArchivo).Close SaveChanges:=False
'
End Sub
'
Sub ConfigurarPagina(h1, h2)
'Por.Dante Amor
    With h2.PageSetup
        .PrintTitleRows = h1.PageSetup.PrintTitleRows
        .PrintTitleColumns = h1.PageSetup.PrintTitleColumns
    End With
    h2.PageSetup.PrintArea = h1.PageSetup.PrintArea
    With h2.PageSetup
        .LeftHeader = h1.PageSetup.LeftHeader
        .CenterHeader = h1.PageSetup.CenterHeader
        .RightHeader = h1.PageSetup.RightHeader
        .LeftFooter = h1.PageSetup.LeftFooter
        .CenterFooter = h1.PageSetup.CenterFooter
        .RightFooter = h1.PageSetup.RightFooter
        .LeftMargin = h1.PageSetup.LeftMargin
        .RightMargin = h1.PageSetup.RightMargin
        .TopMargin = h1.PageSetup.TopMargin
        .BottomMargin = h1.PageSetup.BottomMargin
        .HeaderMargin = h1.PageSetup.HeaderMargin
        .FooterMargin = h1.PageSetup.FooterMargin
        .PrintHeadings = h1.PageSetup.PrintHeadings
        .PrintGridlines = h1.PageSetup.PrintGridlines
        .PrintComments = h1.PageSetup.PrintComments
        .PrintQuality = h1.PageSetup.PrintQuality
        .CenterHorizontally = h1.PageSetup.CenterHorizontally
        .CenterVertically = h1.PageSetup.CenterVertically
        .Orientation = h1.PageSetup.Orientation
        .Draft = h1.PageSetup.Draft
        .PaperSize = h1.PageSetup.PaperSize
        .FirstPageNumber = h1.PageSetup.FirstPageNumber
        .Order = h1.PageSetup.Order
        .BlackAndWhite = h1.PageSetup.BlackAndWhite
        .Zoom = h1.PageSetup.Zoom
        .PrintErrors = h1.PageSetup.PrintErrors
        .OddAndEvenPagesHeaderFooter = h1.PageSetup.OddAndEvenPagesHeaderFooter
        .DifferentFirstPageHeaderFooter = h1.PageSetup.DifferentFirstPageHeaderFooter
        .ScaleWithDocHeaderFooter = h1.PageSetup.ScaleWithDocHeaderFooter
        .AlignMarginsHeaderFooter = h1.PageSetup.AlignMarginsHeaderFooter
        .EvenPage.LeftHeader.Text = h1.PageSetup.EvenPage.LeftHeader.Text
        .EvenPage.CenterHeader.Text = h1.PageSetup.EvenPage.CenterHeader.Text
        .EvenPage.RightHeader.Text = h1.PageSetup.EvenPage.RightHeader.Text
        .EvenPage.LeftFooter.Text = h1.PageSetup.EvenPage.LeftFooter.Text
        .EvenPage.CenterFooter.Text = h1.PageSetup.EvenPage.CenterFooter.Text
        .EvenPage.RightFooter.Text = h1.PageSetup.EvenPage.RightFooter.Text
        .FirstPage.LeftHeader.Text = h1.PageSetup.FirstPage.LeftHeader.Text
        .FirstPage.CenterHeader.Text = h1.PageSetup.FirstPage.CenterHeader.Text
        .FirstPage.RightHeader.Text = h1.PageSetup.FirstPage.RightHeader.Text
        .FirstPage.LeftFooter.Text = h1.PageSetup.FirstPage.LeftFooter.Text
        .FirstPage.CenterFooter.Text = h1.PageSetup.FirstPage.CenterFooter.Text
        .FirstPage.RightFooter.Text = h1.PageSetup.FirstPage.RightFooter.Text
    End With
End Sub
':)
S a l u d o s . D a n t e   A m o r
':) Si es lo que necesitas. Recuerda valorar la respuesta. G r a c i a s.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

¿Extraer los caracteres que hay dentro del segundo paréntesis de un String? En Excel VBA

A tod@s! Tengo una arrray, y en una de las columnas tengo datos, como estos: y necesito encontrar estos caracteres... Ojo que puede haber más de dos "( )" en un String y siempre seria el ultimo "()" comenzando por el ultimo carácter del String. Os...
1 respuesta

¿Como crear un evento al cambiar el valor de una celda con nombre? VBA en Excel

A tod@s! Tengo una celda que se llama "AnalogicaImput". Tengo esta instruccion If Target.Address = "$L$3" Then funciona con la posicion de la celda Como puedo hacer If Target.Name= "AnalogicaImput" Then para ejecutar un evento
1 respuesta

Atascado en la función sumar. Si

En una hoja de calculo tengo en las columnas H, I, J una celda en blanco por columna, en la columna QUE tengo una celda con un numero como referencia 1000 y una celda donde ha de apareceme el resultado siguiente para el cual necesito la fórmula que...
2 respuestas

Cuando ingresos los datos con código no los coloca donde deseo colocar los datos.

Código que extrae información de varios archivos de Excel desde una carpeta pero al colocar los datos los coloca varias filas mas abajo. Debe iniciar a colocar los datos en C6. La información la tiene que colocar dentro de una tabla que tiene...
2 respuestas

Fórmula que separe la fecha por dígitos de uno en cada columna

Necesito una fórmula o macro que separe la fecha en dígitos de uno en cada columna, Ej: 27/03/2025 (col-A(2), col-B(7), col-C(0), col-D(3), col-E(2), col-F(0), col-G(2), col-H(5) Agradecido de antemanos
2 respuestas

Como agregar más hojas a un libro de excel

Dante puede apoyar con la siguiente macro, tengo un archivo de excel en el cual tengo un formato donde hay una macro que cuando se activa un check box muestra ciertas filas y cuando se desactiva las oculta, así mismo bloquea ciertas celdas y también...
1 respuesta

¿Importar datos desde varios libros de Excel ADO?

A tod@s! Desde un botón con su evento aparece un desplegable y elijo los libros que quiero importar la info. Incluso puedo elegir varios a la vez (esto lo tengo hecho) En cada libro seleccionado tendrá una tabla en una hoja llamada "DATA". La tabla...
1 respuesta

¿Cómo se copia una fórmula moviendo solo valores intermedios?

Tengo la siguiente fórmula: ='2025-300'!C$1 Deseo arrastrar la fórmula hacia abajo o copiarla de forma que solo cambie el 300 en el correlativo siguiente: ='2025-301'!C$1 ='2025-302'!C$1 Y asi sucescivamente.
1 respuesta

¿Como adecuar picture de fondo dependiendo de pantalla?

Tengo un libro de Excel que manejo con formularios. Tengo una hoja cuyo fondo tengo una imagen que dependiendo del ordenador en que lo habra, sale desplazado o mas grande... Es decir, me varia dependiendo, creo yo de la resolucion o tamaño de...
2 respuestas

Cargar un rango de datos que tiene algunas filas y columnas vacías a un ListBox vba excel

Me gustaría poder seleccionar un rango de una hoja excel, por ej. Columnas B a I, las filas comenzaría en la 3 hasta final del rango no vacío de la columna C (que es el que contiene mayor numero de filas) y que ese rango se muestre en un ListBox de...
2 respuestas