Macro to create new folder based on previous month and move files

[Alaa mg]

hi experts

I search for macro to create new folder and move the files for each created new folder based on previous month for PC

so every month I have many files contains purchases reports . for instance , take month MAR when the files send me , it will be 1 of APRIL and attach the files in this directory C:\Users\PC AAA\Downloads\REPORT . the macro should create new folder name is REPORT _ 3-2022 based on previous month and move the attached files in main directory in folder REPORT to folder REPORT _ 3-2022 . so if the current month on PC is APRIL should create folder is relating in previous month in PC is MAR and move all of the files are existed from folder REPORT to created new folder REPORT _ 3-2022 and so on for all of the months in current year and when finish this year and enter new year then should start again REPORT _ 1-2023 , REPORT _ 2-2023 . ...

 

[sarathc]

Hopefully this resolves the problem : You can just change 'MyFolPath' and everything else as same.

Sub MoveMonthlyFilesToRespectiveFolders()
Sheets.Add.Name = "FileNames"
Sheets("FileNames").Activate
MyFolPath = "C:\Users\PC AAA\Downloads\REPORT"
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(MyFolPath)
For Each oFile In oFolder.Files
    Cells(i + 1, 1) = oFile.Name
    Cells(i + 1, 2) = FileDateTime(oFolder & "\" & oFile.Name)
    Cells(i + 1, 3) = MonthName(Month(Cells(i + 1, 2))) & "_" & Year(Cells(i + 1, 2))
    i = i + 1
Next oFile
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("D1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$D$1:$D$1048576").RemoveDuplicates Columns:=1, Header:=xlNo
i = 1
Do While Cells(i, 4) <> "" 'Loop through to create folders
    MkDir MyFolPath & "\" & Cells(i, 4).Value
    i = i + 1
Loop
i = 1
Dim FSO As Object
Dim SourceFileName As String, DestinFileName As String
Set FSO = CreateObject("Scripting.Filesystemobject")
Do While Cells(i, 1) <> "" 'Loop through to move files
    SourceFileName = MyFolPath & "\" & Sheets("FileNames").Cells(i, 1).Value
    DestinFileName = MyFolPath & "\" & Cells(i, 3).Value & "\" & Sheets("FileNames").Cells(i, 1).Value
    FSO.MoveFile Source:=SourceFileName, Destination:=DestinFileName
    i = i + 1
Loop
End Sub

Let me know if you are finding any issues.

 

[Alaa mg]

thanks but gives error in the fist line .

 

[sarathc]

Make sure there are no sheets named "FileNames" in your excel file.

 

[Alaa mg]

yes I'm sure . I know to add new sheet

 

[Alaa mg]

another option experts .