Sub PrintFolderList()

    Dim strPath As String
    Dim strFile As String
    Dim strFileSpec As String
    Dim strFilesFound As String
           
    strPath = "Z:\Projects\" ' or wherever you want to look for files
    strFile = Dir(strPath, vbDirectory)
   
    While strFile <> ""
        strFilesFound = strFilesFound & strFile & vbCrLf
        ' get the next file and loop
        strFile = Dir
    Wend
      
    ActiveDocument.Content.InsertAfter Text:=strFilesFound

End Sub

Happy with above - prints out sub folders within a folder. However would like to change dir if a sub folder called "Sites" is found, print out its subfolders (next level only) then return to listing the folders as usual. Anyone any ideas? ie

Folder 1

Folder 2

Folder 3 (has sites so...)

Folder 3\Sites\Site 1

Folder 3\Sites\Site 2

Folder 4 

The best way to do this is to create a collection

Fill it with the directories

Loop through that collection and only get the sub directories for the ones beggining with "Site"

Then outoput the collection.

there are many different folder structure so your best bet is to tailor the sample code below.

    Dim Dirs As New Collection
    Dim strPath As String
    Dim strFile As String
    Dim x As Integer
   
    strPath = "Z:\Projects\"
    strFile = Dir(strPath, vbDirectory)
   
    Do While Len(strFile)
        If strFile <> "." And strFile <> ".." Then
            Dirs.Add strFile
        End If
        strFile = Dir
    Loop

    For x = 1 To Dirs.Count
        strFile = Dir(strPath & Dirs.Item(x) & "\", vbDirectory)
        Debug.Print Dirs.Item(x) & " : " & strFile
        Do While Len(strFile)
            If strFile <> "." And strFile <> ".." And InStr(1, strFile, "Site") > 0 Then
                Dirs.Add strFile
            End If
          strFile = Dir
        Loop
    Next
   
   
   
        For x = 1 To Dirs.Count
              Debug.Print Dirs.Item(x)
        Next
   

 I had problems using Dir() on more than one level, so ended up using:

Set fs = CreateObject("Scripting.FileSystemObject")

strPath = "Z:\Projects\" ' or wherever you want to look for files
strFile = Dir(strPath, vbDirectory)

While strFile <> ""
    strFilesFound = strFilesFound & strFile & vbCrLf
    ActiveDocument.Content.InsertAfter Text:=strFilesFound
           
    If fs.FolderExists(strPath & strFile & "\Sites") Then
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set f = fs.GetFolder(strPath & strFile & "\Sites\")
        Set fc = f.subfolders
           
        For Each f1 In fc
            ActiveDocument.Content.InsertAfter Text:=Left(strFile, 4) & " - Site: " & f1.Name & vbCrLf
        Next
        ActiveDocument.Content.InsertAfter Text:=vbCrLf
    End If
        strFilesFound = ""
        strFile = Dir
    Wend