Copy the folders from an old pst to a new pst with VBA

Copy the following code to your VBA Editor:
Note: Change the "OLD_PST" and "NEW_PST" with the name that you have give to your PST



Sub get_folder_list()

Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olParentFolder As Outlook.MAPIFolder
Dim olFolderA As Outlook.MAPIFolder
Dim olFolderB As Outlook.MAPIFolder

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")

Palio_pst = "Pantelis"
Neo_pst = "pank2"

Set olParentFolder = olNs.Folders(Palio_pst).Folders("Inbox")
Set NEO_ARXEIO = olNs.Folders(Neo_pst).Folders("Inbox")

For Each olFolderA In olParentFolder.Folders
Folders = Folders & olFolderA.FolderPath & ","
'Debug.Print olFolderA.FolderPath, olFolderA.Items.Count, olFolderA.Folders.Count
For Each olFolderB In olFolderA.Folders
Folders = Folders & olFolderB.FolderPath & ","
'Debug.Print olFolderB.FolderPath, olFolderB.Items.Count
Next
Next

Folders = Split(Folders, ",")

'AFAIRESE TO "TITLO PST\Inbox"
For i = 0 To UBound(Folders)
Folders(i) = Replace(Folders(i), "\\" & Palio_pst & "\Inbox\", "")
Next i

'TYPOSETA NA TA DOYME (gia na ta deis prepei na pathseis CTRL+G)
For i = 0 To UBound(Folders)
Debug.Print Folders(i)
Next i

For i = 0 To UBound(Folders)
slash = InStr(Folders(i), "\")

If Folders(i) = "" Then Exit For

If slash > 0 Then
ARXIKOS_FAKELOS = Left(Folders(i), slash - 1)
NEWSUBFOLDER = Mid(Folders(i), slash + 1, Len(Folders(i)) - slash)

'FTIAKSE TO YPO-DIRECTORY
olNs.Folders(Neo_pst).Folders("Inbox").Folders(ARXIKOS_FAKELOS).Folders.Add (NEWSUBFOLDER)

'KSANAKANETO INBOX TO DEFAULT FOLDER
Set NEO_ARXEIO = olNs.Folders(Neo_pst).Folders("Inbox")
End If

If slash = 0 Then
NEO_ARXEIO.Folders.Add (Folders(i))
End If

Next i


End Sub