VBA to create a folder and move

Hi Everyone,

Am new to this forum and i am no expert in VBA but fair in finding codes and applying it into my work.

Am trying to achieve below objective but not successful sofar.

1) I have file with column A, B and C

A column = File Name
B column = Folder Name for each file

C1 = is the path where file to be saved.
C2 = is the path where files are currently stored

I need a code which will create folder(As per column B cell for each file) move the files (stored in C2 path) in it. If folder found, then just move the file and go to next file name. Do the process until last cell value in column A.

Please help.

Thanks

welcome to the forum

since C1 houses the destination folder why do you need the value in column B?
is it parent folder is in C1 and check the existence of the subfolder from C1 + ColB?

An example would help

Quote:

---

Originally Posted by mancubus

welcome to the forum

since C1 houses the destination folder why do you need the value in column B?
is it parent folder is in C1 and check the existence of the subfolder from C1 + ColB?

---

Yes, Parent folder is in C1 and B1 is the subfolder to be created.

Code:

---

Sub vbax_63628_create_folders_move_files()

    Dim prntfldr As String, srcfldr As String, dstfldr As String
    Dim i As Long
   
    Worksheets("Sheet1").Select 'change Sheet1 to suit
   
    prntfldr = Range("C1").Value & "\"
    srcfldr = Range("C2").Value & "\"
   
    With CreateObject("Scripting.FileSystemObject")
        For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
            If Not .FolderExists(prntfldr & Range("B" & i).Value) Then .CreateFolder (prntfldr & Range("B" & i).Value)
            .MoveFile srcfldr & Range("A" & i).Value, prntfldr & Range("B" & i).Value & "\" & Range("A" & i).Value
        Next i
    End With

End Sub

---

ps: backup your files first or copy all in a test folder then test the code.
pps: can be done using array(s) but this should work for you.

Hi,

I tried with your code, am getting error "Run Time error '53: File not found
on below line

Code:

---

Sub vbax_63628_create_folders_move_files()
    Dim prntfldr As String, srcfldr As String, dstfldr As String
    Dim i As Long
   
    Worksheets("Sheet1").Select 'change Sheet1 to suit
   
    prntfldr = Range("C1").Value & "\"
    srcfldr = Range("C2").Value & "\"
   
    With CreateObject("Scripting.FileSystemObject")
        For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
            If Not .FolderExists(prntfldr & Range("B" & i).Value) Then .CreateFolder (prntfldr & Range("B" & i).Value)
            .MoveFile srcfldr & Range("A" & i).Value, prntfldr & Range("B" & i).Value & "\" & Range("A" & i).Value
        Next i
    End With
 End Sub

---

Please advise

Is that because of the file extension which is in .PDF?

Code:

---

.MoveFile srcfldr & Range("A2" & i).Value & ".pdf", prntfldr & Range("B2" & i).Value & "\" & Range("A2" & i).Value & ".pdf"

---

Thanks, it was indeed pdf extension.

Working smooth now.

Thanks a lot mancubus

welcome.

yes. you should provide files' names with their extensions.