Renaming & moving files Using Excel-CodePudding

sorry since i don't know how to code in VBA . i need help create a Code that do the following .

I have 2 columns A : old names , B : New names
I have 2 folders W : Old folder , Z : new Folder
I want the script to go and use the cells that exist in column A and search for files in Folder W and rename them using the new names in column B
then move to folder Z ( each file renamed move to folder Z one by one )
if the file already exist in Folder Z add a number before extension in this manner

Filename (number).extension

why i want it this way ?

I have many audio files that got random numbers on them in folder W and many of files got the same name even though the audio is not the same , so i want each time a file is renamed in folder W to be moved to folder Z and check if a file with excat filename exist if so , add a number before the end just like above .

P.S. i already got files with numbers on them ....(5).ogg so i want the code to be able to read the number 5 and add 6 automatically just like windows does . i have something like 8k files.

I hope the you guys got the general idea and sorry i don't code in VBA . nor do i understand it .

CodePudding user response：

Please, try using the next code. It needs you to set the correct value to oldPath and newPath variables. I used two such variables only to test the code on my environment. It will only return in C:C column information about the moved/copied files:

Sub testMoveChangeName()
 Dim sh As Worksheet, lastR As Long, arr, arrM, i As Long
 Dim oldName As String, newName As String, oldPath As String, newPath As String

 Set sh = ActiveSheet 'use here the sheet you need
 lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row in A:A
 arr = sh.Range("A2:B" & lastR).Value2 'place the range in an array, for faster iteration
 ReDim arrM(1 To UBound(arr), 1 To 1)  'set dimensions for the array to keep the processing feedback
 
 oldPath = ThisWorkbook.Path: newPath = ThisWorkbook.Path & "\NewFolder" 'please, adapt here, using your necessary paths
 For i = 1 To UBound(arr)                            'iterate between the array rows:
    oldName = arr(i, 1): newName = arr(i, 2)         'extract the file names from the array
     
    If Dir(oldPath & "\" & oldName) <> "" Then       'if the combination folder path = file name from the sheet is not wrong:
           If Dir(newPath & "\" & newName) = "" Then 'if not any file with such a name:
               Name oldPath & "\" & oldName As newPath & "\" & newName  ' Move and rename file.
               arrM(i, 1) = "Moved"                                                                           'place the moving status in the array
           Else       'if a file with that name already exists in the new folder:
                 newName = newNm(newName, newPath)                       'rename the new file
                 Name oldPath & "\" & oldName As newPath & "\" & newName ' Move and rename file.
                  arrM(i, 1) = "Moved (with version)"                                                'place the moving status in the array
           End If
    Else
           arrM(i, 1) = "File not found" 'in case of bad old file path
    End If
 Next i
 'drop the status array content at once:
 sh.Range("E2").Resize(UBound(arrM), 1).Value2 = arrM
End Sub

Function newNm(strExisting As String, strFold As String) As String
    Dim arrFiles, arrSuffix, arrName, nrSuffix As Long, i As Long, maxSuffix As Long
       arrName = Split(strExisting, "."): strExisting = arrName(0) 'the name without extension
       arrFiles = getAllF(strFold & "\" & strExisting & "*." & arrName(UBound(arrName))) 'place all files matching the path - name combination in an array
       
       If UBound(arrFiles) = 0 Then                    'if only one file has been found:
                newNm = strExisting & " V01." & arrName(1): Exit Function 'change its name
        Else                                             'if more files have been found:
                For i = 0 To UBound(arrFiles)            'find maximum numeric suffix:
                        arrName = Split(arrFiles(i), "."): strExisting = arrName(0)
                        If IsNumeric(Right(strExisting, 2)) Then
                            arrSuffix = Split(strExisting, " V"): nrSuffix = CLng(arrSuffix(1))
                            If nrSuffix > maxSuffix Then maxSuffix = nrSuffix
                        End If
                Next i
                If maxSuffix > 0 Then
                    newNm = arrSuffix(0) & " V" & Format(nrSuffix   1, "00") & "." & arrName(1)
                Else
                    newNm = strExisting & " V01." & arrName(1)
                End If
        End If
End Function

Private Function getAllF(strFold As String, Optional strExt As String = "*.*") As Variant
    Dim arrFiles
    arrFiles = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & strFold & strExt & """ /b").StdOut.ReadAll, vbCrLf)
    arrFiles(UBound(arrFiles)) = "@@##": getAllF = filter(arrFiles, "@@##", False) 'remove the last (empty) array element
End Function

Please, send some feedback after testing it.

If something not clear enough, do not hesitate to ask for clarifications...

Edited:

Please, use the next procedure to return the number of occurrences for each new Name existing in "B:B". It will return in C:D, so these columns must be empty:

Sub testHowManyIdenticNames()
   Dim sh As Worksheet, lastR As Long, arr, arrFin, i As Long, dict As Object
   
   Set sh = ActiveSheet
   lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
   
   arr = sh.Range("B2:B" & lastR).Value2
   
   Set dict = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(arr)
        dict(arr(i, 1)) = dict(arr(i, 1))   1
   Next i
   arrFin = Application.Transpose(Array(dict.Keys, dict.Items))
   
   sh.Range("C2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
End Sub

I also adapted the original code to return in "E2"...