Die Änderung habe ich gesehen und ausmarkiert. Funktioniert leider trotzdem nicht. Kann es auch daran liegen das nicht beide Pfade gleich aufgebaut sind?

sPath1 = "L:\01_Projekte_#\01_Auftragsordner_#\"
 sPath2 = "\\10.10.100.0\Exchange\Projekte_#\"

Beim ersten sucht er ja nach dem entsprechenden Jahr zur Ablage ab, was beim 2. entfällt. Da gibt es nur den Exchangeordner und dann den Projektordner.

Wie würde das Makro aussehen wen ich nur mit Pfad 2 arbeite?

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long

Public Sub SaveSpecial()
   Dim sPath1 As String, sPath2 As String
  
 sPath1 = "L:\01_Projekte_#\01_Auftragsordner_#\"
 sPath2 = "\\10.10.100.0\Exchange\Projekte_#\"
   
  Call SaveSpecial_mod(sPath1)
  Call SaveSpecial_mod(sPath2)
  
End Sub
Public Sub SaveSpecial_mod(sPath As String)
 
'Const FOLDER_PATH As String = "L:\01_Projekte_#\01_Auftragsordner_#\"
 
    Dim lngYear As Long, lngReturn As Long
    Dim strFolder As String, strSubFolder As String, strValue As String, strFile As String
    Dim blnFound As Boolean
 
    strValue = Split(Cells(2, 10).Text, "-")(0)
    strFile = Cells(2, 10).Text
 
    For lngYear = Year(Date) - 1 To Year(Date) + 1
 
        strFolder = Replace(sPath, "#", CStr(lngYear))

        'strFolder = Replace(FOLDER_PATH, "#", CStr(lngYear))

        lngReturn = MakeSureDirectoryPathExists(strFolder)

        If lngReturn = 0 Then

            Call MsgBox("Ordner kann nicht erstellt werden.", vbCritical, "Dateisystemfehler")
            Exit Sub

        Else

            strSubFolder = Dir$(strFolder & strValue & "*", vbDirectory)

            If strSubFolder <> vbNullString Then

                If InStr(1, ThisWorkbook.Name, "_") = 0 Then
                    strFile = strFile & "_" & ThisWorkbook.Name
                Else
                    strFile = strFile & Mid$(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, "_"))
                End If

                Call ThisWorkbook.SaveAs(Filename:=strFolder & strSubFolder & "\" & _
                    strFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled)
                blnFound = True
                Exit For

            End If
        End If
    Next

    If Not blnFound Then _
        Call MsgBox("Ordner ''" & strValue & "'' nicht gefunden.", _
        vbCritical, "Datei nicht gespeichert")

End Sub