Moving files to their respective folders based on their partial file name

Question

Hope you are doing great!

Would you please help me what code I can use to move files to their respective folders but using only the partial file name? I have successfully created the separate subfolders but I don't know how I will move the files to their respective folders. Here is my working file.

Here is my code to create their folders:

Sub MakeFolders()
Application.ScreenUpdating = False
Sheets("LIST").Select
Range("G12").Select
ActiveCell.Formula2R1C1 = _
        "=UNIQUE(FILTER(RC[-2]:R[188]C[-2],RC[-2]:R[188]C[-2]<>""""))"
Range("G12").Select
Range(Selection, Selection.End(xlDown)).Select
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
Sheets("LIST").Select
Range("G12").Select
Selection.ClearContents
MsgBox ("PM folders created.")
End Sub

What can I add here to move the files to that created folders?

Thank you so much!

Answer 1

Try this - it will move the files and create the subfolders at the same time:

Sub MoveFilesToSubfolders()
    
    Const START_ROW As Long = 12 'first row with data
    Dim wb As Workbook, ws As Worksheet, files As Collection, rw As Range, f
    Dim thefile, fldr, workFolder As String
    
    Set wb = ActiveWorkbook 'or ThisWorkbook if that's where the macro is...
    Set ws = wb.Worksheets("LIST")
    Set rw = ws.Rows(START_ROW) 'first row with data
    workFolder = wb.Path
    'add terminating \ if missing
    If Right(workFolder, 1) <> "\" Then workFolder = workFolder & "\"
    
    Do While Len(rw.Columns("B").Value) > 0
        
        fldr = rw.Columns("E").Value
        If Len(Dir(workFolder & fldr, vbDirectory)) = 0 Then
            MkDir (workFolder & fldr)
        End If
        'find any matching files
        Set files = GetFileMatches(workFolder, "*" & rw.Columns("B").Value & "*.zip")
        If files.Count > 0 Then
            For Each f In files 'loop over matched files and move them
                Name workFolder & f As workFolder & fldr & "\" & f
            Next f
        Else
            MsgBox "No file(s) found for row# " & rw.Row  
        End If
        'next row down
        Set rw = rw.Offset(1)
    Loop

End Sub


'Return a collection of file paths given a starting folder and a file pattern
'  e.g. "*.txt"
Function GetFileMatches(startFolder As String, filePattern As String) As Collection
    Dim f, colFiles As New Collection
    If Right(startFolder, 1) <> "\" Then startFolder = startFolder & "\"
    f = Dir(startFolder & filePattern) 'find first file
    Do While Len(f) > 0
        colFiles.Add f
        f = Dir() 'next file(s) if exist
    Loop
    Set GetFileMatches = colFiles
End Function

Answer 2

Backup (Move) Files

• You only run BackupFiles, the rest is being called.

Option Explicit

Sub BackupFiles()
    
    Const wsName As String = "LIST"
    Const foFirst As String = "E2"
    Const fiCol As String = "B"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    ' Folder Range
    Dim forg As Range: Set forg = RefColumn(ws.Range(foFirst))
    If forg Is Nothing Then Exit Sub
    Dim foData As Variant: foData = GetColumn(forg)
    
    ' File Range
    Dim firg As Range: Set firg = forg.EntireRow.Columns(fiCol)
    Dim fiData As Variant: fiData = GetColumn(firg)
    
    ' Source Folder Path
    Dim sPath As String: sPath = wb.Path & "\"
    
    ' All Files in the Source Folder
    Dim FilePaths As Variant: FilePaths = ArrFilePaths(sPath, 1)
    Dim FileNames As Variant: FileNames = ArrFileNames(sPath, 1)
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim fsoFile As Object
    Dim rIndex As Variant
    Dim r As Long
    Dim dPath As String ' Destination Folder Path
    
    For r = 1 To UBound(foData)
        rIndex = Application.Match("*" & fiData(r, 1) & "*", FileNames, 0)
        If IsNumeric(rIndex) Then
            dPath = sPath & foData(r, 1) & "\"
            If Not fso.FolderExists(dPath) Then
                fso.CreateFolder dPath
            End If
            Set fsoFile = Nothing
            On Error Resume Next
            ' Prevent "Run-time Error 53: File not found" i.e.
            ' if a file contains several strings, it has been moved already.
            Set fsoFile = fso.Getfile(FilePaths(rIndex))
            On Error GoTo 0
            If Not fsoFile Is Nothing Then
                If fso.FileExists(dPath & FileNames(rIndex)) Then
                    fsoFile.Copy dPath ' , True ' overwriting by default
                    fsoFile.Delete
                Else
                    fsoFile.Move dPath
                End If
            End If
        End If
    Next r
    
    MsgBox "Files moved.", vbInformation, "Backup Files"

End Sub

Function RefColumn( _
    ByVal FirstCellRange As Range) _
As Variant
    If FirstCellRange Is Nothing Then Exit Function
    With FirstCellRange.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With
End Function

Function GetColumn( _
    ByVal ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    With ColumnRange.Columns(1)
        Dim Data As Variant
        If .Cells.Count = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data = .Value
        Else
            Data = .Value
        End If
        GetColumn = Data
    End With
End Function

Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FirstIndex As Long = 0) _
As Variant
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(FolderPath) Then
        Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
        Dim FilesCount As Long: FilesCount = fsoFolder.Files.Count
        If FilesCount > 0 Then
            Dim n As Long: n = FirstIndex - 1
            Dim arr As Variant: ReDim arr(FirstIndex To FilesCount + n)
            Dim fsoFile As Object
            For Each fsoFile In fsoFolder.Files
                n = n + 1
                arr(n) = fsoFile.Path
            Next fsoFile
            ArrFilePaths = arr
        End If
    End If
End Function

Function ArrFileNames( _
    ByVal FolderPath As String, _
    Optional ByVal FirstIndex As Long = 0) _
As Variant
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(FolderPath) Then
        Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
        Dim FilesCount As Long: FilesCount = fsoFolder.Files.Count
        If FilesCount > 0 Then
            Dim n As Long: n = FirstIndex - 1
            Dim arr As Variant: ReDim arr(FirstIndex To FilesCount + n)
            Dim fsoFile As Object
            For Each fsoFile In fsoFolder.Files
                n = n + 1
                arr(n) = fsoFile.Name
            Next fsoFile
            ArrFileNames = arr
        End If
    End If
End Function