Запретить открытие дубликатов папок или подпапок в проводнике Windows

Это сделает это:

Function isFolderOpen(Path As String) As Boolean
    Dim sh As Object, w As Object, Document
    Set sh = CreateObject("shell.application")
    For Each w In sh.Windows
        If w.Name = "Windows Explorer" Or w.Name = "File Explorer" Then
        Debug.Print w.Document.folder.self.Path
            Set Document = w.Document
            If Document.folder.self.Path = Path Then
                isFolderOpen = True
                Exit Function
            End If
        End If
    Next
End Function

Ссылка: Excel VBA для открытия только одного экземпляра проводника

Дополнение

Function isFolderOpenOrSubFolder(Path As String) As Boolean
    Dim sh As Object, w As Object, Document
    Set sh = CreateObject("shell.application")
    For Each w In sh.Windows
        If w.Name = "Windows Explorer" Or w.Name = "File Explorer" Then
            Set Document = w.Document
            If Left(Document.folder.self.Path, Len(Path)) = Path Then
                isFolderOpenOrSubFolder = True
                Exit Function
            End If
        End If
    Next
End Function

Чтобы проверить, открыта ли папка или какая-либо из ее подпапок, попробуйте следующую функцию:

Function isFoldSubFoldOpen(strFolder As String, Optional boolSubFld As Boolean = False) As Boolean
        Dim oShell As Object, Wnd As Object, sFld As Variant

        Set oShell = CreateObject("Shell.Application")
        If boolSubFld Then
            Dim fso As Object, fold As Object, colSFld As New Collection
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set fold = fso.GetFolder(strFolder)
            AllSubFolders fold, colSFld
        End If
        For Each Wnd In oShell.Windows
            If Wnd.name = "Windows Explorer" Or Wnd.name = "File Explorer" Then
               If Wnd.Document.folder.Self.path = strFolder Then isFoldSubFoldOpen = True: Exit Function
               If boolSubFld Then
                    For Each sFld In colSFld
                         If Wnd.Document.folder.Self.path = sFld Then
                            Debug.Print Wnd.Document.folder.Self.path
                            isFoldSubFoldOpen = True: Exit Function
                        End If
                    Next sFld
              End If
            End If
        Next Wnd
End Function

Ему также нужен рекурсивный Sub, который помещает все подпапки в коллекцию:

Private Sub AllSubFolders(FSOFolder As Object, colSFld As Collection)
 Dim objSubfold As Object, objFile As Object

 For Each objSubfold In FSOFolder.SubFolders
    colSFld.Add objSubfold                 'place the subfolder in the collection
    AllSubFolders objSubfold, colSFld 'recursively call the sub itself
 Next
End Sub

Вышеуказанная функция может быть вызвана только для возврата True, если папка открыта (без второго параметра или с ним False) или любая из ее подпапок:

  Debug.Print isFoldSubFoldOpen(FolderPath)       'check if the folder is open
  Debug.Print isFoldSubFoldOpen(FolderPath, True) 'check if the folder or any of its sub-folders are open