Exportar en la carpeta creada, no funciona

Tengo esto y funciona perfecto. Lo único es que cuando crea la carpeta no exporta en ella sino afuera en la otra que la contiene..

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)
  carpetafinal = ruta & ruta4
'Folder crear o encontrar
    Application.ScreenUpdating = False
    Set Carpeta = CreateObject("Scripting.FileSystemObject")
         '
  'nombre del archivo
  Namek = num & ("-") & Format(Now, "ddmmyyyy")
If ruta4 <> "" Then
      MsgBox "ENCONTRADO.", vbInformation, "Kutools for Excel"
  'Exportar archivo
      Sheets("PDF").ExportAsFixedFormat xlTypePDF, carpetafinal & "\" & Namek & ".pdf", xlQualityStandard, True, False, , , False
      Else
       Carpeta.CreateFolder (ruta3)
        MsgBox "CREADA.", vbInformation, "Kutools for Excel"
       Sheets("PDF").ExportAsFixedFormat xlTypePDF, carpetafinal & "\" & Namek & ".pdf", xlQualityStandard, True, False, , , False
        End If
Sheets("Ficha").Select
    End Sub

1 Respuesta

Respuesta
1

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

[Prueba y comentas. 

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas