Move files from one folder to another and rename it, if the file exist then add number 1,2, etc in increment (VBA)

feni1388

Board Regular
Joined
Feb 19, 2018
Messages
78
Office Version
  1. 2021
Platform
  1. Windows
Hello...
I have a list of company's name, company's code, its current location and new folder path.

Everyday my colleague or I need to move all the files in each folder, no matter what extension it is (excel, CSV, PDF) to another folder and rename it (the same extension and only the name is changed).
I want to do it with macro but I only know how to write simple VBA code and I can't find the suitable VBA code in the internet.

I need macro to go through the list, move all files in each folder to another folder and rename it. The new name is today's date, company's code and number (this number is in increment, so the first file will be 1,
the next is 2 and so on. For example : 240522_COC01000_1 and the second file is 240522_COC01000_2 and so on.
but if there's any file's name that contain the word PO in it, then the name will also reflect it (240522_COC01000_PO_1)

Can anyone please help?

PS: the list can grow longer, so I want the user to add the company's code, name, file path and its destination only without changing the VBA code itself.

CodeCompany's nameCurrent folderNew folder
COC01000CompanyA\\obcsvr\Share\【admin】\westadmin\property\CompanyA\\obcsvr\Share\【report】\maker\PO\west
FRM01000CompanyB\\obcsvr\Share\【admin】\westadmin\property\CompanyB\\obcsvr\Share\【report】\maker\PO\west
HCA01000CompanyC\\obcsvr\Share\【admin】\westadmin\property\CompanyC\\obcsvr\Share\【report】\maker\PO\west
HIM01000CompanyD\\obcsvr\Share\【admin】\westadmin\property\CompanyD\\obcsvr\Share\【report】\maker\PO\west
HIM02000CompanyE\\obcsvr\Share\【admin】\westadmin\property\CompanyE\\obcsvr\Share\【report】\maker\PO\west
HIM03000CompanyF\\obcsvr\Share\【admin】\westadmin\property\CompanyF\\obcsvr\Share\【report】\maker\PO\west
HIM04000CompanyG\\obcsvr\Share\【admin】\westadmin\property\CompanyG\\obcsvr\Share\【report】\maker\PO\west
KEG01000CompanyH\\obcsvr\Share\【admin】\westadmin\property\CompanyH\\obcsvr\Share\【report】\maker\PO\west
MBS05000CompanyI\\obcsvr\Share\【admin】\westadmin\property\CompanyI\\obcsvr\Share\【report】\maker\PO\west
MCB61000CompanyJ\\obcsvr\Share\【admin】\westadmin\property\CompanyJ\\obcsvr\Share\【report】\maker\PO\west
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Try this macro. I would test it on a subset copy (sheet data with only the first 3 companies) of the current folders.

VBA Code:
Public Sub Rename_and_Move_Files()

    Dim data As Variant
    Dim currentFolder As String, newFolder As String
    Dim CompanyCode As String, fileName As String
    Dim r As Long, n As Long, p As Long
   
    data = ActiveSheet.Range("A1").CurrentRegion.Value
   
    For r = 2 To UBound(data)
        CompanyCode = data(r, 1)
        currentFolder = data(r, 3)
        If Right(currentFolder, 1) <> "\" Then currentFolder = currentFolder & "\"
        newFolder = data(r, 4)
        If Right(newFolder, 1) <> "\" Then newFolder = newFolder & "\"
        n = 0
        fileName = Dir(currentFolder & "*.*")
        While fileName <> vbNullString
            n = n + 1
            p = InStrRev(fileName, ".")
            If InStr(fileName, "PO") Then
                Name currentFolder & fileName As newFolder & Format(Date, "yymmdd_") & CompanyCode & "_PO_" & n & Mid(fileName, p)
            Else
                Name currentFolder & fileName As newFolder & Format(Date, "yymmdd_") & CompanyCode & "_" & n & Mid(fileName, p)
            End If
            fileName = Dir
        Wend
    Next
   
    MsgBox "Done"
   
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,216,503
Messages
6,131,020
Members
449,615
Latest member
Nic0la

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