VBA Macro move files to sub folders

Romanzar

New Member
Joined
Mar 16, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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

1616597515951.png



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 :)
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Try this macro, changing the source and destination folders as required.
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top