Imprimir PDF con nombre y carpeta específica

Tengo este código; sin embargo quisiera que me guardara automáticamente el PDF con un nombre de una celda y en una carpeta específica de la ruta2. Las carpetas que están en la ruta2 se nombran PEPITO PEREZ 2343, ANDRES PEREZ 5333, quisiera que me guardara en pepito perez la información del PDF en su carpeta. Gracias

Sub GUARDAR()
Application.ScreenUpdating = False
'Abre word
  Dim num As Variant
  Dim ruta As String
  Dim TEX2 As String, TEX3 As String
  Dim WordApp As Object
  Dim wdDoc As Object
  'Dim WordApp As Word.Application
  'Dim wdDoc As Word.Document
  '
  'Ambiente
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
    '
  num = Worksheets("Ficha").Range("F2").Value
  ruta = Environ("USERPROFILE") & "\Dropbox\DOCUMENTOS PERSONALES\CONSULTORIO\hISTORIAS CLINICAS\TODAS\"
  ruta2 = Environ("USERPROFILE") & "\Dropbox\DOCUMENTOS PERSONALES\CONSULTORIO\hISTORIAS CLINICAS\"
    '
  'Buscar archivos en la ruta con el número
  archi = Dir(ruta & "*" & num & "*.docx")
  archi2 = Dir(ruta & "*" & num & "*.docx")
 If archi <> "" Then
    'Verifica si el archivo está abierto
    If IsFileOpen(ruta & archi) Then
      Set WordApp = GetObject(, "Word.Application")
      Set wdDoc = WordApp.Documents(ruta & archi)
      WdDoc. Activate
            'CC
    Sheets("Ficha"). Range("F2"). Copy
    'Se pegara en el documento lo copiado en la hoja de calculo
    WordApp.Selection.EndKey Unit:=6
    WordApp. Selection.Move 1, 1
    WordApp. Selection. TypeParagraph
    WordApp.Selection.Font.Name = "Century Gothic"
    WordApp.Selection.Font.TextColor = RGB(255, 0, 0)
    WordApp.Selection.Paragraph.Alignment = wdAlignParagraphRight
    WordApp. Selection. PasteAndFormat 2
'Indicaciones
    Sheets("Ficha"). Range("C19"). Copy
    'Se pegara en el documento lo copiado en la hoja de calculo
    WordApp.Selection.EndKey Unit:=6
    WordApp. Selection.Move 1, 1
    WordApp. Selection. PasteSpecial 7
        WordApp.Documents.Save False
     Filename = ruta2 & Range("C10") & ".pdf"
                 'Activar documento
    WordApp.Activate
    'Imprimir
    WordApp.PrintOut Range:=2 ' wdPrintCurrentPage
    'Reset impresora
     Application.ActivePrinter = "Microsoft Print to PDF"
    ActiveDocument.PrintOut
         'Cerrar word
    WordApp.Quit
     Set WordApp = Nothing
    Set wdDoc = Nothing
  End If
  End Sub