Ошибка выполнения 76 Путь не найден, но работает 49 раз - PullRequest
0 голосов
/ 18 июня 2020

Этот Код срабатывает 49 раз, но в 50-й раз возникает ошибка, отмеченная в данной строке (почти в конце кода). Не знаю почему, потому что 49 раз программа находит путь… Может, вы понимаете почему. Спасибо за помощь

Sub Excel_to_Powerpoint()

Dim pptPres As PowerPoint.Presentation
Dim pptApp As Object
Dim pptVorlage As String
Dim Speicher1 As String
Dim Speicher2 As String
Dim fso As FileSystemObject
Dim i As Integer

    For i = 1 To 1200

    If Sheets(1).Cells(6 + i, 5) = "" Then

    Else

    Set fso = New FileSystemObject

    pptVorlage = "D:\Users\BKU\CedricWirth\Desktop\DHBW_Mosbach\T2000\Test\VorlagePSB.potx"

    Set pptApp = CreateObject("Powerpoint.Application")
    pptApp.Visible = True
    pptApp.Activate

    Set pptPres = pptApp.Presentations.Open(pptVorlage)


    pptPres.Slides(1).Select

    pptPres.Slides(1).Shapes("Projektnummer").TextFrame.TextRange.Characters.Text = Sheets(1).Cells(6 + i, 5).Value


    Speicher1 = "D:\Users\BKU\CedricWirth\Desktop\DHBW_Mosbach\T2000\Test\Projektsteckbriefe\Projektsteckbrief_" & Sheets(1).Cells(6 + i, 5) & "_" & Sheets(1).Cells(6 + i, 13) & ".pptx"
    Speicher2 = "D:\Users\BKU\CedricWirth\Desktop\DHBW_Mosbach\T2000\Test\Projektsteckbriefe\Projektsteckbrief2_" & Sheets(1).Cells(6 + i, 5) & ".pptx"

    pptPres.SaveAs (Speicher2)

    If fso.FileExists(Speicher1) = True Then
        Call fso.DeleteFile(Speicher1)
        pptPres.Close
        Set pptPres = Nothing
        pptApp.Quit
        Set pptApp = Nothing
        Call fso.Movefile(Speicher2, Speicher1)
    Else
        pptPres.Close
        Set pptPres = Nothing
        pptApp.Quit
        Set pptApp = Nothing
        Call fso.Movefile(Speicher2, Speicher1) "Here is the Error"
    End If

    End If
    Next i

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...