Runtime Error '-2147024773 (8007007b)'

[Doerte]

Hello,
I get above mentioned error code when I try to run the following macro:

Sub PrintAndSavePdf()

    Dim strFileName As String
    Dim strPath As String
    Dim ws As Worksheet
    Dim strPathSplit As Variant
    Dim myTempPath As String
   

    For Each ws In ActiveWorkbook.Worksheets
   
        If ws.Name <> "Master" Then

            strFileName = ws.Range("I2") & ".pdf"
            strPath = ws.Range("I1")
       
            myTempPath = ""
           
             If Dir(strPath, vbDirectory) = "" Then
           
                strPathSplit = Split(strPath, "\\")
                If UBound(strPathSplit) > 0 Then
                    myTempPath = "\\"
                    strPathSplit = Split(strPathSplit(1), "\")
                End If
               
                myTempPath = myTempPath & strPathSplit(0) & "\"
               
                For i = 1 To UBound(strPathSplit)
                    myTempPath = myTempPath & strPathSplit(i) & "\"
                    If Dir(myTempPath, vbDirectory) = "" Then
                        MkDir (myTempPath)
                    End If
                Next i
               
            End If
           
        ws.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=strPath & strFileName, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        End If
   
    Next ws
End Sub

Someone gave me this code, but it does not work.

It is an excelmap containing app 70 different worksheets.
On each worksheet there is in cell I1 the path to a server address (IP/path) and in cell I2 the file name, which contains "year name.02.01 - name"
Each sheet has the be stored as pdf under the mentioned path (I1) with the mentioned name (I2)
If the path does not exist the macro should create this path and store the file as descibed.

The red marked section turns to yellow when I open the debug mode.

Can anyone pls help?

 

[Alex Blakenburg]

Rather than try and figure out one sheet failing to save at a time, you can try running this code.
It will create a new workbook that lists all the sheets that errored out trying to save.
This will most likely be due to the some sort of error in the file name or file path.

Hopefully you haven't made any changes to your original code (apart from perhaps adding the debug statements we discussed)

Sub PrintAndSavePdf_WithErrorList()

    Dim strFileName As String
    Dim strPath As String
    Dim ws As Worksheet
    Dim strPathSplit As Variant
    Dim myTempPath As String
    Dim i As Long                   'XXX Missing Dim from original code needs to be added
    
    '---------- Added For Error Checking ----------
        Dim arrWS()
    Dim arrCnt As Long
    Dim newWB As Workbook
    
    ReDim arrWS(1 To ActiveWorkbook.Worksheets.Count, 1 To 4)
    arrCnt = 0
    '----------------------------------------------
    
   

    For Each ws In ActiveWorkbook.Worksheets
   
        If ws.Name <> "Master" Then

            strFileName = ws.Range("I2") & ".pdf"
            strPath = ws.Range("I1")
       
            myTempPath = ""
           
             If Dir(strPath, vbDirectory) = "" Then
           
                strPathSplit = Split(strPath, "\\")
                If UBound(strPathSplit) > 0 Then
                    myTempPath = "\\"
                    strPathSplit = Split(strPathSplit(1), "\")
                End If
               
                myTempPath = myTempPath & strPathSplit(0) & "\"
               
                For i = 1 To UBound(strPathSplit)
                    myTempPath = myTempPath & strPathSplit(i) & "\"
                    If Dir(myTempPath, vbDirectory) = "" Then
                        MkDir (myTempPath)
                    End If
                Next i
               
            End If
           
        On Error Resume Next                 'XXX Added - Let code continue if a sheet fails to save
        
        ws.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=strPath & strFileName, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        End If
        
        '---------- Added For Error Checking ----------
        If Err Then
            arrCnt = arrCnt + 1
            arrWS(arrCnt, 1) = ws.Name
            arrWS(arrCnt, 2) = ws.Range("I2")
            arrWS(arrCnt, 3) = ws.Range("I1")
            arrWS(arrCnt, 4) = strPath & strFileName
            On Error GoTo -1
        End If
    
        '----------------------------------------------
   
    Next ws
    
    '---------- Added For Error Checking ----------
    Set newWB = Workbooks.Add

    ActiveSheet.Range("A4").Resize(UBound(arrWS, 1), UBound(arrWS, 2)).Value = arrWS
    
    'Headings and formatting
    With ActiveSheet.Range("A3:D3")
        .Value = Array("Sheet Name", "I2 Value", "I1 Value", "Path & File")
        .EntireColumn.AutoFit
        .Font.Bold = True
    End With
    
        With ActiveSheet.Range("A1")
        .Value = "Sheets that errored out"
        .Font.Size = 14
        .Font.Bold = True
    End With
    '----------------------------------------------
    
End Sub