Copy Folders into a new directory without copying the files contained within

[Viva_Excel]

Hello,

We have a folder directory structure that we use every month. We want to be able to copy the tree structure each month without copying all the files inside the folders. Is there a way to copy the folders to the subsequent month without copying over the files contained within them. I am not sure if this is the correct forum for this but not sure where to turn. Anyone have any ideas?

Thanks!!!!!!

 

[SydneyGeek]

Create a new file that you will use for driving these updates, and save it.

Enter this data on Sheet1:
In F1: Old Folder
In F2: New Folder
In G1: The full path of the top folder in the tree you want to move (eg, H:\Documents\Oct 2012)
In G2: The pull path for the new directory tree (eg, H:\Documents\Nov 2012)
Name cell G1 OldDir
Name cell G2 NewDir

Paste this code into a new module (Note: This borrows heavily from http://www.cpearson.com/excel/RecursionAndFSO.htm)

Option Explicit
    Dim FSO As Scripting.FileSystemObject
    Dim intIndent As Integer '0 for listing in 1 column; 1 for indenting at each folder level
    Dim TopFolderName As String
    Dim NewFolderName As String
    Sub StartListing()
        Dim TopFolderObj As Scripting.Folder
        Dim DestinationRange As Range
        Dim c As Range
        intIndent = 0
        
        TopFolderName = [OldDir] '<<< CHANGE TO YOUR FOLDER
        NewFolderName = [NewDir]
        Set DestinationRange = Worksheets(1).Range("A1")
        DestinationRange.CurrentRegion.ClearContents
        If FSO Is Nothing Then
            Set FSO = New Scripting.FileSystemObject
        End If
        Set TopFolderObj = FSO.GetFolder(TopFolderName)
        
        ListSubFolders OfFolder:=TopFolderObj, _
            DestinationRange:=DestinationRange, _
            IndentLevel:=intIndent
        
        If Not FSO Is Nothing Then
            Set FSO = Nothing
        End If
        
        'copy folder names to B1
        Range("A1").CurrentRegion.Copy
        Range("B1").PasteSpecial
        
        Selection.Replace TopFolderName, NewFolderName
        Application.CutCopyMode = False
        
        For Each c In Selection
            MkDir c.Value
        Next c
    End Sub
    Sub ListSubFolders(OfFolder As Scripting.Folder, _
            DestinationRange As Range, _
            IndentLevel As Integer)
        Dim SubFolder As Scripting.Folder
        DestinationRange.Value = OfFolder.Path
        Set DestinationRange = DestinationRange.Offset(1, IndentLevel)
        For Each SubFolder In OfFolder.SubFolders
            ListSubFolders OfFolder:=SubFolder, _
                DestinationRange:=DestinationRange, _
                IndentLevel:=intIndent
        Next SubFolder
        'return to next level up once all subfolders are written out
        If intIndent > 0 Then
            Set DestinationRange = DestinationRange(1, 0)
        End If        
    End Sub

Create a reference to the Microsoft Scripting Runtime
Run the StartListing procedure (Alt+F8, double-click the name)

Columns A and B will have the old and new names, and the directory tree will have been copied.

Denis