Sub MakeFolders()
  'requires reference to Microsoft Scripting Runtime
  Dim subFolders() As String, sPath As String, aCell As Range
  Dim iNum As Long, sCell As String, sFolder As String, i As Integer
  Dim sPathF As String, sPathSubF As String
  Dim fso As New FileSystemObject
  
  sPath = "C:\Temp\"
  subFolders = Split("Calculations|Capacities|Correspondence|Inspections", "|")
  
  For Each aCell In Selection
    sCell = Trim(aCell.Value)
    iNum = Mid(sCell, 3)
    sFolder = "PN" & Format(iNum, "00000")
    sPathF = sPath & sFolder
    If Not fso.FolderExists(sPathF) Then fso.CreateFolder sPathF
    For i = LBound(subFolders) To UBound(subFolders)
      sPathSubF = sPathF & "\" & sFolder & " - " & subFolders(i)
      If Not fso.FolderExists(sPathSubF) Then fso.CreateFolder sPathSubF
    Next i
  Next aCell
End Sub