VBA Macro move files to sub folders

[Romanzar]

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

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

 

[John_w]

Try this macro, changing the source and destination folders as required.

Public Sub Move_Files_LB()

    Dim sourceFolder As String, destinationFolder As String
    Dim data As Variant
    Dim i As Long
    Dim Wsh As Object
    
    sourceFolder = "C:\path\to\PDF files\"              'CHANGE THIS
    destinationFolder = "C:\path\to\dest folder\"       'CHANGE THIS
    
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
    
    Set Wsh = CreateObject("WScript.Shell")
    data = ActiveSheet.UsedRange.Value
    For i = 2 To UBound(data)
        If Dir(sourceFolder & data(i, 1)) <> vbNullString Then
            Wsh.Run "cmd /c MKDIR " & Chr(34) & destinationFolder & data(i, 4) & "\" & data(i, 3) & "\" & data(i, 2) & Chr(34), 0, True
            Name sourceFolder & data(i, 1) As destinationFolder & data(i, 4) & "\" & data(i, 3) & "\" & data(i, 2) & "\" & data(i, 1)
        Else
            MsgBox sourceFolder & data(i, 1), Title:="Source file not found"
        End If
    Next
    
End Sub

 

[Romanzar]

It works very well ?

Thank you