Seleccionar un directorio y guardar copia excel o pdf
Para Dante
Buenos días Dante, necesito otra vez de tu apoyo. Necesito que me muestre una ventana para elegir el directorio y guardar, dependiendo de la opción que yo elija. De ya gracias.
Private Sub CommandButton4_Click()
Application.ScreenUpdating = False
Set h1 = Sheets("BIBLIOTECA")
Ruta = ThisWorkbook.Path & "\"
arch = "Reporte"
'
If ComboBox1 = "" Or ComboBox1.ListIndex = -1 Then
MsgBox "Seleccione un reporte"
Exit Sub
End If
'
If OptionButton1 Then
h1.Copy
'guarda archivo como versión 2007 o superior
ActiveWorkbook.SaveAs _
Filename:=Ruta & arch & " " & Format(Time, "hh-mm-ss") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox "Fin"
habilitado = False
Unload Me
FrmInicio.Show
End If
'
If OptionButton2 Then
h1.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Ruta & arch & Format(Date, "yyyy-mm-dd") & ".pdf", _
quality:=xlQualityStandard, includedocproperties:=True, _
ignorePrintAreas:=False, openAfterPublish:=False
Application.ScreenUpdating = True
MsgBox "Fin"
habilitado = False
Unload Me
FrmInicio.Show
End If
If OptionButton3 Then
MsgBox "Seguimos trabajando", vbInformation, Strtitulo
Exit Sub
'Por.DAM
' Application.ScreenUpdating = False
' Application.DisplayAlerts = False
' If Range("A1") = "" Then Exit Sub
' n = Range("A1")
' Range("C2:O30").Copy
' Workbooks.Add
' ActiveSheet.Paste
' ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\ARCHIVO\" & n & ".txt", _
' FileFormat:=xlTextMSDOS, CreateBackup:=False
' ActiveWorkbook.Close False
' MsgBox "Archivo: " & n & " creado", vbInformation, "CREAR TXT"
End If
End Sub
1 Respuesta
Respuesta de Dante Amor
1
Código actualizado
Private Sub CommandButton4_Click()
Application.ScreenUpdating = False
Set h1 = Sheets("BIBLIOTECA")
ruta = ThisWorkbook.Path & "\"
arch = "Reporte"
'
If ComboBox1 = "" Or ComboBox1.ListIndex = -1 Then
MsgBox "Seleccione un reporte"
Exit Sub
End If
'
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
ruta = .SelectedItems(1) & "\"
End With
If OptionButton1 Then
h1.Copy
'guarda archivo como versión 2007 o superior
ActiveWorkbook.SaveAs _
Filename:=ruta & arch & " " & Format(Time, "hh-mm-ss") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox "Fin"
habilitado = False
Unload Me
FrmInicio.Show
End If
'
If OptionButton2 Then
h1.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & arch & Format(Date, "yyyy-mm-dd") & ".pdf", _
quality:=xlQualityStandard, includedocproperties:=True, _
ignorePrintAreas:=False, openAfterPublish:=False
Application.ScreenUpdating = True
MsgBox "Fin"
habilitado = False
Unload Me
FrmInicio.Show
End If
If OptionButton3 Then
MsgBox "Seguimos trabajando", vbInformation, Strtitulo
Exit Sub
'Por.DAM
' Application.ScreenUpdating = False
' Application.DisplayAlerts = False
' If Range("A1") = "" Then Exit Sub
' n = Range("A1")
' Range("C2:O30").Copy
' Workbooks.Add
' ActiveSheet.Paste
' ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\ARCHIVO\" & n & ".txt", _
' FileFormat:=xlTextMSDOS, CreateBackup:=False
' ActiveWorkbook.Close False
' MsgBox "Archivo: " & n & " creado", vbInformation, "CREAR TXT"
End If
End Subsal u dos
