Hey guys,
I have a list of .pdf files that I need to move into a subfolder (fir folder), which needs to be moved into another subfolder (sec fold), which needs to be moved into another one (thr fold).
file / fir fold / sec fold / thr fold
all the files located in a test folder and I don't have existing folders.
I was looking around for a macro but the only thing I have found is this code
It creates the folder and moves the files into it but it wont create multiple sub folders
Thanks in advance
I have a list of .pdf files that I need to move into a subfolder (fir folder), which needs to be moved into another subfolder (sec fold), which needs to be moved into another one (thr fold).
file / fir fold / sec fold / thr fold
all the files located in a test folder and I don't have existing folders.
I was looking around for a macro but the only thing I have found is this code
VBA Code:
Option Explicit
Sub MoveFiles()
' 02 Oct 2017
Dim Src As String ' source path
Dim Dest As String ' Target path
Dim Fn As String ' file name
Dim Fold As String ' folder name in "B"
Dim Rl As Long ' last row in column B
Dim R As Long ' row counter
With ActiveSheet
If TestPaths(Src, Dest) Then
Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
' ' start in row 2, presuming 1 to have captions:
For R = 2 To Rl
Fn = Trim(.Cells(R, "B").Value)
Fold = Dest & Trim(.Cells(R, "C").Value)
If FolderName(Fold, True) Then
On Error Resume Next
' Debug.Print R, Src & Fn & " = " & Fold & "\" & Fn
Name Src & Fn As Fold & Fn
If Err Then
MsgBox "File " & Fn & vbCr & _
"in row " & R & " couldn't be moved." & vbCr & _
"Error " & Err & " - " & Err.Description
End If
End If
' DoEvents
If (Rl - R) Mod 50 = 0 Then Application.StatusBar = Rl - R & " records remaining"
Next R
End If
End With
End Sub
Private Function TestPaths(Src As String, _
Dest As String) As Boolean
' 02 Oct 2017
' both arguments are return strings
' This is the address of your folder "A":
Const SourcePath As String = "C:\My Documents\A"
' This is the address of your folder "B":
Const TargetPath As String = "C:\My Documents\B"
Dim Fn As String
Src = SourcePath
If FolderName(Src, False) Then
Dest = TargetPath
TestPaths = FolderName(Dest, True)
End If
End Function
Private Function FolderName(Ffn As String, _
CreateIfMissing As Boolean) As Boolean
' 02 Oct 2017
' Ffn is a return string
Dim Sp() As String
Dim i As Long
Ffn = Trim(Ffn)
Do While Right(Ffn, 1) = "\"
Ffn = Left(Ffn, Len(Ffn) - 1)
Loop
Sp = Split(Ffn, "\")
Ffn = ""
For i = 0 To UBound(Sp)
Ffn = Ffn & Sp(i) & "\"
On Error Resume Next
If Len(Dir(Ffn, vbDirectory)) = 0 Then
If Err Then
MsgBox Err.Description & vbCr & _
"Error No. " & Err, vbCritical, "Fatal error"
Exit Function
Else
If CreateIfMissing Then
MkDir Ffn
Else
MsgBox "The given path doesn't exist:" & vbCr & _
Ffn, vbCritical, "Set-up error"
Exit Function
End If
End If
End If
Next i
FolderName = (i > 0)
End Function
It creates the folder and moves the files into it but it wont create multiple sub folders
Thanks in advance