.saveas command not working at certain folder levels

[mcledavid]

I have written code to automatically open, rename, and save embedded workbooks in an excel spreadsheet to a file. I will post the code below. For some reason, all of the code works, except when I hit the ".saveas" command. If the files are saved in the same folder as the workbook with the embedded files, then it will save all the files. However, if I save the files at in a subfolder, the saveas command will run without error, but the document will never show up in the folder. Am I missing something? Code is posted below.

Sub SaveExistingExcelDoc()
    Dim MyDir As String
    Dim strPath As String
    Dim xlApp As Excel.Application
    Dim xlDoc As Excel.Workbook
    Dim windowCt As Integer
    Dim objct As OLEObject
    Dim DocName As String
    Dim FinalDest2 As String
    MyDir = ActiveWorkbook.Path
    CheckDir = MyDir
    On Error Resume Next
    
a = 1
Worksheets(a).Activate
    
    
Do While a <= Worksheets.Count
For Each objct In ActiveSheet.OLEObjects
    ActiveSheet.Shapes(objct).Select
    objtype = objct.progID
    If objct.TopLeftCell.Column = "3" Then
            docTitle1 = Cells(objct.TopLeftCell.Row, 1).Value
            docTitle2 = "Touchpoint"
            'MsgBox (docTitle1 & " " & docTitle2)
            DestFldr = "\Sample Touchpoint"
        ElseIf objct.TopLeftCell.Column = "19" Then
            docTitle1 = Cells(objct.TopLeftCell.Row, 1).Value
            docTitle2 = "Internal Performance"
            'MsgBox (docTitle1 & " " & docTitle2)
            DestFldr = "\Internal Perf Reports"
        ElseIf objct.TopLeftCell.Column = "21" Then
            docTitle1 = Cells(objct.TopLeftCell.Row, 1).Value
            docTitle2 = "Competitive Intelligence"
            'MsgBox (docTitle1 & " " & docTitle2)
            DestFldr = "\Comp Intel Reports"
        ElseIf objct.TopLeftCell.Column = "23" Then
            docTitle1 = Cells(objct.TopLeftCell.Row, 1).Value
            docTitle2 = "Consituent Opinions"
            'MsgBox (docTitle1 & " " & docTitle2)
            DestFldr = "\Constituent Opinions"
        End If
        strPath = MyDir & DestFldr
        DocName = docTitle1 & " " & docTitle2
        Select Case objct.progID
            Case "Excel.Sheet.8"
                Selection.Verb Verb:=xlOpen
                Set xlDoc = ActiveWorkbook
                GoTo Line29:
                If xlApp Is Nothing Then
                    Set xlApp = GetObject("Excel.Application")
                    xlApp.Visible = True
                End If
                On Error GoTo 0
                On Error Resume Next
                If xlApp.Windows.Count > 0 Then
                    Set xlDoc = xlApp.ActiveWorkbook
                Else
                    Set xlDoc = xlApp.Documents.Add
                End If
                On Error GoTo 0

Line29:
                With xlDoc
                    MsgBox xlDoc.Name
                    'strTitle = InputBox("what should the file be named?", FileSaveAs, "Test")
                    'strTitle = "THIS IS A TEST2"
                    '.SaveAs (MyDir & "\" & DocName & ".xls")
                    MsgBox strPath
                    MsgBox strPath & "- " & DocName
                    .SaveAs Filename:=(strPath & "\" & DocName & ".xls"), FileFormat:=xlNormal, Password:="", WriteResPassword:="password", ReadOnlyRecommended:=True_, CreateBackup:=False
                    .Close
                End With
                'xlApp.Quit
    

                ' Clean up
                Set xlDoc = Nothing
                'Set WrdApp = Nothing
        End Select
        Next
        a = a + 1
TheBottom:
If a > Worksheets.Count Then
    MsgBox "Done Processing"
    Exit Sub
End If
Worksheets(a).Activate
Loop
End Sub