VBA code to move multiple files to different folders based on the file name

[MissaLissa]

Excel Guru's ray:

I have approx 30 excel files that I need to move to different folders based on the file name. The folders that these files are being moved to already exist. I have some code but it only moves one file, I need help adjusting the code to move all of them to their corresponding folders. Any help would be greatly appreciated.

Move LTCi_Operations.xlsx to folder named LTCi Operations
Move AS_Operations.xlsx to folder named AS Operations
Move Assessment_Services.xlsx to folder named Assessment Services
Etc...

Sub Move_Final_Reports()    

    sSaveFrom = "\\ltcgsrv1\CognosExpress\Final Reports\"
    sSaveTo = "\\ltcgsrv1\CognosExpress\Final Reports\LTCi\LTCi Operations\"
    sFile = "*LTCi_Operations*.xl*"
    
    Set FSO = CreateObject("scripting.filesystemobject")
    
    FSO.MoveFile Source:=sSaveFrom & sFile, Destination:=sSaveTo
    
End Sub

 

[John_w]

Duplicate of http://www.mrexcel.com/forum/excel-...r-folder-based-workbook-name.html#post4121860

 

[MissaLissa]

Yes, that would work. However, I want to be able to push one button to move all files.

 

[Kaps_mr2]

In a single column, list (on distinct rows) all your file names, and then create a FOR NEXT loop to iterate through the list, and move them accordingly. Thanks

Kaps

 

[MissaLissa]

Thanks Kaps... could you help me write that code? Would it be something like this... I tested this but somethings not correct because it keeps barking at me.

My List

[TABLE="width: 1080"]
<tbody>[TR]
[TD]Filename[/TD]
[TD]Source Folder[/TD]
[TD]Destination Folder[/TD]
[/TR]
[TR]
[TD]IS-3 (Budget) - Actuary.xlsx[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports\Shared Services\SS Consulting[/TD]
[/TR]
[TR]
[TD]IS-3 (Budget) - Claims_Exam.xlsx[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports\LTCi\Claims Exam[/TD]
[/TR]
[TR]
[TD]IS-3 (Budget) - Claims_Shared_Services.xlsx[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports\LTCi\Claims Shared Services[/TD]
[/TR]
[TR]
[TD]IS-3 (Budget) - Clinical_Services.xlsx[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports\Shared Services\SS Consulting[/TD]
[/TR]
[TR]
[TD]IS-3 (Budget) - CM_Bankers.xlsx[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports[/TD]
[TD]\\ltcgsrv1\CognosExpress\Final Reports\LTCi\CM - Bankers[/TD]
[/TR]
</tbody><colgroup><col><col><col></colgroup>[/TABLE]

Sub Move_Final_Reports()
     
    Dim c As Excel.Range
    Dim strName As String
    Dim strDir As String
     
    For Each c In Sheet1.Range("A2").Resize(Sheet1.Range("A" & Rows.Count).End(xlUp).Row - 1)
        If c.Value <> vbNullString Then
            If c.Offset(0, 1).Value <> vbNullString And c.Offset(0, 2).Value <> vbNullString Then
                strName = c.Offset(0, 1).Value & IIf(Right$(c.Offset(0, 1).Value, 1) <> "\", "\", vbNullString) & c.Value
                strDir = c.Offset(0, 2).Value & IIf(Right$(c.Offset(0, 2).Value, 1) <> "\", "\", vbNullString)
                If Dir(strName) <> vbNullString Then
                    If Dir(strDir, vbDirectory) <> vbNullString Then
                        FileCopy strName, strDir & c.Value
                        Kill strName
                    End If
                End If
            End If
        End If
    Next
     
End Sub