Macro que Guardar archivo en pdf, y ahora que sea en xlsx

A los miembros de este foro, quisiera ver la posibilidad de mejorar la macro, esta macro me permite grabar en PDF ahora lo que me piden es grabar .xlsx, bajo el mismo detalle:

Dim valor As String: Dim NOMBRE As String
Private Sub CommandButton1_Click()
Sheets("boleta").Select
End
End Sub

Private Sub ListBox1_Click()
'Act.Por.Dante Amor
LIMPIA
Set x = Worksheets("BOLETA")
Set y = Worksheets("TRABAJADOR")
valor = ListBox1.Value
numero = ListBox1.ListIndex + 1
Set Z = x.Range("b:b")
With Z
Set busca = .Find(valor, LookIn:=xlValues)
End With
r = busca.Address
ri = Range(r).Offset(-10, -1).Address
'rf = Range(ri & ":m" & numero * 62).Address
rf = Range(ri & ":o" & numero * 67).Address
PREGUNTA = MsgBox("¿GENERAR PDF? ", vbYesNo, "AVISO")
If PREGUNTA = vbYes Then
CARPETA2
'ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address
'Set rng = Range(ActiveSheet.UsedRange.Address)
x.Range(rf).ExportAsFixedFormat Type:=xlTypePDF, _
fileName:=NOMBRE, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=True, _
From:=1, To:=10, OpenAfterPublish:=False
MsgBox "El archivo PDF fue generado en: " & NOMBRE & ".pdf"
Else
End
End If
End Sub
Private Sub OptionButton1_Click()
guardar_pdf
End Sub

Private Sub UserForm_Activate()

Set x = Worksheets("BOLETA")
x.Select

LIMPIA
With UserForm1
.Caption = "CONVERTIR PDF"
.Move 150, 10
End With

celda = x.Range("B11").Value

a = 0
Do While celda <> Empty
celda = x.Range("B11").Offset(a, 0).Value
If celda = Empty Then Exit Do
ListBox1.AddItem celda
a = a + 67
Loop

End Sub
Sub LIMPIA()
Set x = Worksheets("BOLETA")
Set y = Worksheets("TRABAJADOR")

For Each PIC In y.Pictures
PIC.Delete
Next PIC

'Set Z = y.Range("A1:M62")
Set Z = y.Range("A1:O67")
Z.ClearContents

End Sub

Sub CARPETA2()
Set fso = CreateObject("Scripting.FileSystemObject")
Dim archivos As String
Dim contador As Integer

respuesta = MsgBox(ActiveWorkbook.Path, vbYesNo, "USAR CARPETA")

If respuesta = vbYes Then
directorio = ActiveWorkbook.Path
Else
titulo = "Selecciona la ruta de tu carpeta"
On Error Resume Next
With CreateObject("shell.application")
directorio = .browseforfolder(0, titulo, 0).Items.Item.Path
End With: On Error GoTo 0
If directorio = "" Then
MsgBox "No has marcado ningún directorio.", , "Operación no válida"
End
Else
MsgBox "Ha seleccionado la siguiente ruta " & directorio
End If
End If

RES = MsgBox("¿Guardar con el nombre de: " & valor & ".pdf", vbYesNo, "AVISO")

If RES = vbYes Then
hoja = valor
Else
hoja = InputBox("TECLEA UN NOMBRE:", "AVISO")
If hoja = Empty Then End
End If

NOMBRE = directorio & "\" & hoja

End Sub

El siguiente codigo forma parte de la primera descripción, y esperando contar con su valioso aporte, quedo agradecido siempre de uds.

Dim NOMBRE As String
Sub guardar_pdf()
CARPETA
ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address

Set rng = Range(ActiveSheet.UsedRange.Address)

rng.ExportAsFixedFormat Type:=xlTypePDF, _
fileName:=NOMBRE, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=True, _
From:=1, To:=10, OpenAfterPublish:=False
Range("A1").Select

MsgBox "El archivo PDF fue generado en: " & NOMBRE & ".pdf"
End Sub
Sub CARPETA()
Set fso = CreateObject("Scripting.FileSystemObject")
Dim archivos As String
Dim contador As Integer

respuesta = MsgBox("Usar carpeta por default", vbYesNo, "AVISO")

If respuesta = vbYes Then
directorio = ActiveWorkbook.Path
Else
titulo = "Selecciona la ruta de tu carpeta"
On Error Resume Next
With CreateObject("shell.application")
directorio = .browseforfolder(0, titulo, 0).Items.Item.Path
End With: On Error GoTo 0
If directorio = "" Then
MsgBox "No has marcado ningún directorio.", , "Operación no válida"
End
Else
MsgBox "Ha seleccionado la siguiente ruta " & directorio
End If
End If

RES = MsgBox("¿Guardar con nombre por default?", vbYesNo, "AVISO")

If RES = vbYes Then
hoja = ActiveSheet.Name
Else
hoja = UCase(InputBox("TECLEA UN NOMBRE:", "AVISO"))
End If

NOMBRE = directorio & "\" & hoja

End Sub
'REVISAR ESTA RUTINA
Sub ajustar()
Range("a68").Select
n = Range("a68").Value
Do While ActiveCell <> Empty
Set x = ActiveCell.Resize(2, 2)
x.EntireRow.Insert
ActiveCell.Offset(69, 0).Select
Loop
End Sub
Sub forma()
UserForm1.Show
End Sub

1 Respuesta

Respuesta
2

Cambia tu evento Listbox1_Click por lo siguiente:

Private Sub ListBox1_Click()
    LIMPIA
    Set x = Worksheets("BOLETA")
    Set y = Worksheets("TRABAJADOR")
    valor = ListBox1.Value
    numero = ListBox1.ListIndex + 1
    Set Z = x.Range("b:b")
    With Z
        Set busca = .Find(valor, LookIn:=xlValues)
    End With
    r = busca.Address
    ri = Range(r).Offset(-10, -1).Address
    'rf = Range(ri & ":m" & numero * 62).Address
    rf = Range(ri & ":o" & numero * 67).Address
    PREGUNTA = MsgBox("¿GENERAR PDF? ", vbYesNo, "AVISO")
    If PREGUNTA = vbYes Then
        CARPETA2
        'ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address
        'Set rng = Range(ActiveSheet.UsedRange.Address)
        x.Range(rf).ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=NOMBRE, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=True, _
            From:=1, To:=10, OpenAfterPublish:=False
        '
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        n = Application.SheetsInNewWorkbook
        Application.SheetsInNewWorkbook = 1
        x.Range(rf).Copy
        Workbooks.Add
        ActiveWorkbook.Range("A1").PasteSpecial xlPasteValues
        ActiveWorkbook.Range("A1").PasteSpecial xlPasteFormats
        ActiveWorkbook.SaveAs _
            Filename:=NOMBRE, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
        Application.SheetsInNewWorkbook = n
        Application.ScreenUpdating = False
        '
        MsgBox "El archivo PDF fue generado en: " & NOMBRE & ".pdf"
    Else
        End
    End If
End Sub

Lo que hace es generar el pdf y también un xlsx con la misma información.

Prueba y me comentas.

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Hola Amigo Dante Amor, reemplazando la macro anterior por la nueva rutina que brindas, me emite el siguiente error, adjunto imagen

Espero tu apreciación, gracias.

Prueba con esta:

Private Sub ListBox1_Click()
    LIMPIA
    Set x = Worksheets("BOLETA")
    Set y = Worksheets("TRABAJADOR")
    valor = ListBox1.Value
    numero = ListBox1.ListIndex + 1
    Set Z = x.Range("b:b")
    With Z
        Set busca = .Find(valor, LookIn:=xlValues)
    End With
    r = busca.Address
    ri = Range(r).Offset(-10, -1).Address
    'rf = Range(ri & ":m" & numero * 62).Address
    rf = Range(ri & ":o" & numero * 67).Address
    PREGUNTA = MsgBox("¿GENERAR PDF? ", vbYesNo, "AVISO")
    If PREGUNTA = vbYes Then
        CARPETA2
        'ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address
        'Set rng = Range(ActiveSheet.UsedRange.Address)
        x.Range(rf).ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=NOMBRE, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=True, _
            From:=1, To:=10, OpenAfterPublish:=False
        '
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        n = Application.SheetsInNewWorkbook
        Application.SheetsInNewWorkbook = 1
        x.Range(rf).Copy
        Workbooks.Add
        ActiveSheet.Range("A1").PasteSpecial xlPasteValues
        ActiveSheet.Range("A1").PasteSpecial xlPasteFormats
        ActiveWorkbook.SaveAs _
            Filename:=NOMBRE, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
        Application.SheetsInNewWorkbook = n
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        '
        MsgBox "El archivo PDF fue generado en: " & NOMBRE & ".pdf"
    Else
        End
    End If
End Sub

Avísame cualquier duda

Amigo Dante Amor, la macro ahora ya quedo OK, es decir genera el archivo pdf como el xlsx, solo un pequeño detalle, que, al generar el archivo en excel este queda descuadrado adjunto imagen, y si no fuese molestia solicitarte tú apoyo para que quede igual que archivo en pdf


Agradezco nuevamente tu colaboración, caso contrario daría como tema solucionado, gracias.

Después de esta línea:

ActiveSheet. Range("A1"). PasteSpecial xlPasteFormats

Agrega esta línea:

ActiveWorkbook. Range("A1"). PasteSpecial xlPasteColumnWidths

Es difícil competir contra excel, lo que hace esta línea, es enviar un rango de celdas, directamente a una impresora, en este caso, a la impresora "PDF", internamente existe un programa (ExportAsFixedFormat), que tiene un código para determinar cómo imprimir el PDF

x.Range(rf).ExportAsFixedFormat Type:=xlTypePDF

Lo que pides es enviar un rango a un archivo de excel, eso no existe.

Si lo que quieres es toda la hoja, entonces cambia la macro por esta:

Private Sub ListBox1_Click()
    LIMPIA
    Set x = Worksheets("BOLETA")
    Set y = Worksheets("TRABAJADOR")
    valor = ListBox1.Value
    numero = ListBox1.ListIndex + 1
    Set Z = x.Range("b:b")
    With Z
        Set busca = .Find(valor, LookIn:=xlValues)
    End With
    r = busca.Address
    ri = Range(r).Offset(-10, -1).Address
    'rf = Range(ri & ":m" & numero * 62).Address
    rf = Range(ri & ":o" & numero * 67).Address
    PREGUNTA = MsgBox("¿GENERAR PDF? ", vbYesNo, "AVISO")
    If PREGUNTA = vbYes Then
        CARPETA2
        'ActiveSheet.PageSetup.PrintArea = ActiveSheet.UsedRange.Address
        'Set rng = Range(ActiveSheet.UsedRange.Address)
        x.Range(rf).ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=NOMBRE, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=True, _
            From:=1, to:=10, OpenAfterPublish:=False
        '
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        'n = Application.SheetsInNewWorkbook
        'Application.SheetsInNewWorkbook = 1
        'x.Range(rf).Copy
        'Workbooks. Add
        x. Copy
        'ActiveWorkbook. Range("A1"). PasteSpecial xlPasteValues
        'ActiveWorkbook. Range("A1"). PasteSpecial xlPasteFormats
        'ActiveWorkbook. Range("A1"). PasteSpecial xlPasteColumnWidths
        ActiveWorkbook.SaveAs _
            Filename:=NOMBRE, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
        'Application.SheetsInNewWorkbook = n
        Application.ScreenUpdating = False
        '
        MsgBox "El archivo PDF fue generado en: " & NOMBRE & ".pdf"
    Else
        End
    End If
End Sub

Prueba ambos casos.

sal u dos

¡Gracias! Amigo Dante Amor, solo era una sugerencia que se me había ocurrido, y como indicas estuve navegando por internet y es cierto que para grabar un pdf tiene su propia regla

x.Range(rf).ExportAsFixedFormat Type:=xlTypePDF

Por lo demás, la macro quedo OK. por lo que agradezco tú colaboración brindada, por lo que daria como TEMA RESUELTO.

Gracias.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

¿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

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...
1 respuesta

¿Macro al escribir carácter en un rango de Excel?

A tod@s! Tengo una hoja llamada Acción y lo que quiero es que en cualquier celda de la columna C, cada vez que escriba un carácter ejecute una acción o macro. ¿Cómo puedo hacerlo?
1 respuesta

Agregar y ocultas celdas con botón

Tengo varios archivos Excel donde manejo información por semanas, pero cada semana tengo que ocultar la semana que ya pasó y agregar una semana nueva, son 45 pestañas! Es un lio hacer una por una. Quisiera saber si hay una manera de que con un botón...
1 respuesta