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

1 respuesta

Respuesta
3

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) Then

Lo 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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas