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

[feni1388]

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.

Code	Company's name	Current folder	New folder
COC01000	CompanyA	\\obcsvr\Share\【admin】\westadmin\property\CompanyA	\\obcsvr\Share\【report】\maker\PO\west
FRM01000	CompanyB	\\obcsvr\Share\【admin】\westadmin\property\CompanyB	\\obcsvr\Share\【report】\maker\PO\west
HCA01000	CompanyC	\\obcsvr\Share\【admin】\westadmin\property\CompanyC	\\obcsvr\Share\【report】\maker\PO\west
HIM01000	CompanyD	\\obcsvr\Share\【admin】\westadmin\property\CompanyD	\\obcsvr\Share\【report】\maker\PO\west
HIM02000	CompanyE	\\obcsvr\Share\【admin】\westadmin\property\CompanyE	\\obcsvr\Share\【report】\maker\PO\west
HIM03000	CompanyF	\\obcsvr\Share\【admin】\westadmin\property\CompanyF	\\obcsvr\Share\【report】\maker\PO\west
HIM04000	CompanyG	\\obcsvr\Share\【admin】\westadmin\property\CompanyG	\\obcsvr\Share\【report】\maker\PO\west
KEG01000	CompanyH	\\obcsvr\Share\【admin】\westadmin\property\CompanyH	\\obcsvr\Share\【report】\maker\PO\west
MBS05000	CompanyI	\\obcsvr\Share\【admin】\westadmin\property\CompanyI	\\obcsvr\Share\【report】\maker\PO\west
MCB61000	CompanyJ	\\obcsvr\Share\【admin】\westadmin\property\CompanyJ	\\obcsvr\Share\【report】\maker\PO\west

 

[John_w]

Try this macro. I would test it on a subset copy (sheet data with only the first 3 companies) of the current folders.

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

 

[feni1388]

Thank you so much.....
It works perfectly.