répertoire au-dessus

Sub TestParent()
Dim file As String
Dim filename As String
Dim position As Integer
   file = ThisWorkbook.FullName
   filename = ThisWorkbook.Name
   position = InStr(1, file, filename, 1)
   position = position - 2
   file = Left(file, position)
  MsgBox file
End Sub

Sub test()
Dim Chemin As String, Mon_Dossier As String
Dim i As Integer

Chemin = ThisWorkbook.Path

While Mid(Chemin, Len(Chemin), 1) <> "\"
    Chemin = Mid(Chemin, 1, Len(Chemin) - 1)
Wend
For i = Len(Chemin) - 1 To 1 Step -1
    If Mid(Chemin, i, 1) = "\" Then
        Mon_Dossier = Mid(Chemin, i + 1, Len(Chemin) - i - 1)
        Exit For
    End If
Next i

Msgbox Mon_Dossier
End Sub

Function nFich(tText As String)
If InStr(Right$(tText, Len(tText) - InStr(tText, "\")), "\") <> 0 Then
    tText = Right$(tText, Len(tText) - InStr(tText, "\"))
       a = nFich(tText)
    nFich = Left$(tText, InStr(tText, "\") - 1)
Else
    nFich = "Le fichier " & tText & " est déjà à la racine !"
End If
End Function

Sub go()
MsgBox "Nom du dossier parent : " & nFich("C:\REPERTOIRE1\REP2\HELLO\IMAGES\PORNO\VIOLENT\OURSON\Bébé.gif") ' A Adapter ^^
End Sub

Repdudessus = Dir(ActiveWorkbook.Path, vbDirectory)