Create Folders and Move Files Using VBA/MACRO

Hi all,

I'm not sure if this is even possible but here goes.

I have a folder FULL of files.

On each filename, the first 6 digits contains a reference number

e.g.
123456_456_BE.jpg
123456_457_BE.jpg
123456_458_BE.jpg

For each file in the folder i want to create a folder with the name being the first 6 digits of the file (the reference).

so for the above i would end up with one folder named 123456 and that would have three files inside -
123456_456_BE.jpg
123456_457_BE.jpg
123456_458_BE.jpg

thanks in advance

Cj

Here is one way.

Sub x()
     
Dim oFile         As Object
Dim oSubFolder    As Object
Dim oFolderFile   As Object
Dim strParentPath As String
 
Set oFile = CreateObject("Scripting.FileSystemObject")

strParentPath = "H:\VBA test\"  'change starting folder

With oFile
    For Each oFolderFile In .GetFolder(strParentPath).Files
        If Not .folderexists(Left(oFolderFile.Name, 6)) Then
            .createfolder (Left(oFolderFile.Name, 6))
        End If
        .MoveFile oFolderFile, strParentPath & "\" & Left(oFolderFile.Name, 6) & "\"
    Next oFolderFile
End With
     
End Sub

I tried the sample macro above and it worked great until I attempted to move a file to a network folder on a sharepoint site. I've been able to save excel files to these folders using VBA and would love to be able to move other files into them as well. Does anyone have any suggestions or can I just not save files to a sharepoint site this way?