Create Subfolders using VBA

Question

I have to add an empty subfolder called "2012" in about 1000 files, all in one directory.  Then I have to move anything with "2012" in the title into those folders.  Just to be clear here's a word pic"

C:  MainFolder \ subfolder 1 \ 2012

\ subfolder 2 \ 2012

\ subfolder 3 \ 2012

etc.

Can anyone help?

Thanks!

Answer 1

Here is a starting point.  Assuming you want to  add it to all first level subfolders of the main folder, try this

Option Explicit

Sub AddSubfolder()

'Under tools, add reference to Microsoft Scripting Runtime

Dim FSO As Scripting.Filesystemobject

Dim RootFolder As Object

Dim SubFolder As Object

Dim myFolder As String

Dim myNewFolder As String

Set FSO = CreateObject("Scripting.FileSystemObject")

myFolder = "C:\Users\User.Name\Documents"   'Change to identify your main folder

Set RootFolder = FSO.GetFolder(myFolder)

For Each SubFolder In RootFolder.SubFolders

    Debug.Print SubFolder.Path

    myNewFolder = SubFolder.Path & "\2012"

    If Not FSO.FolderExists(myNewFolder) Then

        MkDir (myNewFolder)

    End If

Next SubFolder

End Sub

Answer 2

To move a file with 2012 ANYWHERE in the name from the subfolder to the newfolder, try this.  I'd STRONGLY recommend that you step through this code using F8 until you are sure it does what you want. 

Sub AddSubfolder()

'Under tools, add reference to Microsoft Scripting Runtime

Dim FSO As Scripting.Filesystemobject

Dim RootFolder As Object

Dim SubFolder As Object

Dim myFolder As String

Dim myNewFolder As String

Dim mySubfolderPath As String

Dim myFile As String

Set FSO = CreateObject("Scripting.FileSystemObject")

myFolder = "C:\Users\barbara.reinhardt\Documents"   'Change to identify your main folder

Set RootFolder = FSO.GetFolder(myFolder)

For Each SubFolder In RootFolder.SubFolders

    Debug.Print SubFolder.Path

    mySubfolderPath = SubFolder.Path

    myNewFolder = mySubfolderPath & "\2012"

    If Not FSO.FolderExists(myNewFolder) Then

        MkDir (myNewFolder)

        myFile = Dir(mySubfolderPath & "\*2012*")

        Do While myFile <> ""

            FSO.MoveFile mySubfolderPath & "" & myFile, myNewFolder & "" & myFile

            myFile = Dir

        Loop

    End If

Next SubFolder

End Sub

Answer 3

How about this an alternative

Public Function NewFolder(strFolder As String) As Boolean

  Dim fso As New FileSystemObject

  Dim strParentFolder As String

On Error GoTo NewFolder_Error

    strParentFolder = fso.GetParentFolderName(strFolder)

    If Not fso.FolderExists(strParentFolder) Then

        NewFolder strParentFolder

        If Not fso.FolderExists(strParentFolder) Then

            fso.CreateFolder strParentFolder

        End If

        If fso.FolderExists(strParentFolder) Then

            fso.CreateFolder strFolder

            NewFolder = True

        End If

    Else

        If fso.FolderExists(strParentFolder) Then

            fso.CreateFolder strFolder

            NewFolder = True

        End If

    End If

NewFolder_Error:

    If Err Then

        MsgBox "Error " & Err.Number & " (" & Err.Description & ") "

        Err.Clear

    End If

    Set fso = Nothing

End Function

Call NewFolder "C:\Temp\T1\T2\T3\T4"

Answer 4

A zillion hours!  Wow!  ;)   I'm glad I could help.  

Barb Reinhardt

Answer 5

Barb, This worked perfectly and will save me a zillion hours.  Thank you so much!