Seleccionar una carpeta VBA con un número
Quisiera seleccionar una carpeta que contiene un numero, para exportar dentro una hoja de excel como pdf
Tengo varias carpetas así :
1. Frutas - 2568
2. Frutas - 4856
3. Frutas - 5866
Quisiera poder seleccionar una teniendo en cuenta el número digamos 2568 me selecciona Frutas - 2568 y ahi exportar una hoja de excel como pdf. No sé si es posible...
Prueba lo siguiente.
Agregué unos comentarios en el código para que lo ajustes a tu necesidad.
Sub SelCarpeta()
Dim num As String, arch As Variant
Dim carpetaInicial As String, carpetafinal As String
carpetaInicial = "C:\trabajo\"
num = "2568" 'puedes tomarlo de una celda, ej. num = range("A2")
arch = Dir(carpetaInicial & "*" & num, vbDirectory)
If arch <> "" Then
carpetafinal = carpetaInicial & arch
'en esta línea poner la hoja a exportar y el nombre del archivo pdf
Sheets("Hoja1").ExportAsFixedFormat xlTypePDF, carpetafinal & "\" & "nombre archivo" & ".pdf", xlQualityStandard, True, False, , , False
Else
MsgBox "No existe una carpeta con el número : " & num
End If
End Sub
Gracias, funciona bien. Pero al exportar me sale un error. El documento puede estar abierto o se encontró un error al guardar.
Sub GUARDAR()
'On Error Resume Next
'Abre word
Dim num As Variant
Dim base2 As String
Dim Namek As String
Dim Carpeta As Object
Dim ruta As String
Dim ruta3 As String
Dim ruta4 As Variant
Dim carpetafinal As String
'Ambiente
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
num = Sheets("Ficha").Range("F2").Value
ruta = Environ("USERPROFILE") & "\Dropbox\TODAS\"
'datos para la carpeta
base2 = Cells(4, "F") & " " & Cells(4, "G") & " " & Cells(4, "C") & " " & Cells(4, "D") & "-" & num
'ruta completa
ruta3 = ruta & base2
ruta4 = Dir(ruta & "*" & num, vbDirectory)
'Folder crear o encontrar
Application.ScreenUpdating = False
Set Carpeta = CreateObject("Scripting.FileSystemObject")
If Carpeta.FolderExists(ruta3) Then
MsgBox "ENCONTRADO.", vbInformation, "Kutools for Excel"
Else
Carpeta.CreateFolder (ruta3)
MsgBox "CREADA.", vbInformation, "Kutools for Excel"
End If
' '
'nombre del archivo
Namek = num & ("-") & Format(Now, "ddmmyyyy")
If ruta4 <> "" Then
'Exportar archivo
Sheets("PDF").ExportAsFixedFormat xlTypePDF, ruta4 & "\" & Namek & ".pdf", xlQualityStandard, True, False, , , False
End If
Sheets("Ficha").Select
End Sub
Está creando la carpeta ruta3
Carpeta. CreateFolder (ruta3)
Pero quieres exportar en la capeta ruta4
Sheets("PDF"). ExportAsFixedFormat xlTypePDF, ruta4
En mi código utilizo la función dir( ) para revisar si existe la carpeta.
arch = Dir(carpetaInicial & "*" & num, vbDirectory)
En tu código, la variable ruta4 no es necesaria, porque estás utilizando esto para revisar si existe la carpeta:
Set Carpeta = CreateObject("Scripting.FileSystemObject")
If Carpeta.FolderExists(ruta3) ThenLo siguiente debería funcionar para lo que necesitas:
Sub GUARDAR()
Dim num As Variant
Dim Carpeta As Object
Dim base2 As String, Namek As String
Dim ruta As String, ruta3 As String
'Ambiente
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
ruta = Environ("USERPROFILE") & "\Dropbox\TODAS\"
num = Sheets("Ficha").Range("F2").Value
'datos para la carpeta
base2 = Cells(4, "F") & " " & Cells(4, "G") & " " & Cells(4, "C") & " " & Cells(4, "D") & "-" & num
ruta3 = ruta & base2
'Folder crear o encontrar
Set Carpeta = CreateObject("Scripting.FileSystemObject")
If Carpeta.FolderExists(ruta3) Then
MsgBox "ENCONTRADO.", vbInformation, "Kutools for Excel"
Else
Carpeta.CreateFolder (ruta3)
MsgBox "CREADA.", vbInformation, "Kutools for Excel"
End If
'nombre del archivo
Namek = num & ("-") & Format(Now, "ddmmyyyy")
'Exportar archivo
Sheets("PDF").ExportAsFixedFormat xlTypePDF, ruta3 & "\" & Namek & ".pdf", xlQualityStandard, True, False, , , False
Sheets("Ficha").Select
End Sub
