Sub x()
Dim swFolder As Office.SharedWorkspaceFolder
Dim swParent As Office.SharedWorkspaceFolder
Dim newFolder As Office.SharedWorkspaceFolder
If ActiveWorkbook.SharedWorkspace.Folders.ItemCountExceeded = True Then
MsgBox "No more Folders or Files can be created automatically." & vbCrLf & _
"The displayable number of 99 folders and files has been exceeded.", _
vbInformation, "ItemCountExceeded"
ElseIf ActiveWorkbook.SharedWorkspace.Folders.Count > 0 And _
ActiveWorkbook.SharedWorkspace.Folders.Count < 99 Then
For Each swFolder In ActiveWorkbook.SharedWorkspace.Folders
If swFolder.FolderName = "searched Folder" Then
Set swParent = swFolder
End If
Next
Set newFolder = ActiveWorkbook.SharedWorkspace.Folders.Add("MyNewFolder", Parent)
MsgBox "New Folder: " & newFolder.FolderName, _
vbInformation + vbOKOnly, _
"New Folder in Shared Workspace"
End If
Set newFolder = Nothing
Set swParent = Nothing
End Sub