Outlookで指定した名前のフォルダを一括で作る

自分用。多分すでに同名のフォルダが存在するとエラーになると思う。

Public Sub CreateFolders()
Dim CurrentFolder As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Dim List As New VBA.Collection
Dim Folders As Outlook.Folders
Dim Item As Variant

List.Add Array("あいうえお", olFolderInbox)
List.Add Array("かきくけこ", olFolderInbox)

Set CurrentFolder = Application.ActiveExplorer.CurrentFolder
Set Folders = CurrentFolder.Folders
For Each Item In List
    Folders.Add Item(0), Item(1)
Next
End Sub