WaveOMutilation 0 Newbie Poster

Hi,

A few years ago, me and a colleague built the below code as a tool for our team to automatically update the names on our saved files in line with the company records management policy. Now that policy has changed and I need to update the code, and unfortunately my much cleverer colleague who did the more complicated bits has left the company.

Would much appreciate input from anyone on the code, particularly how the bit highlighted in bold actually works. Neither of us had any training or experience in coding at the point we did this, so also feel free to point out superior ways of achieving the end result. Ideally I would also like to expand it to be able to run over multiple sub folders in one run if required.

Many thanks

Matt

Option Explicit

Sub Change_File_Name()
Dim sSht As Worksheet: Set sSht = ThisWorkbook.Sheets("Macro")
Dim tSht As Worksheet: Set tSht = ThisWorkbook.Sheets("Log of file name changes")
Dim strPath As String
Dim sP, tVal As String
Dim oldName(1) As String
Dim newName(1) As String
Dim nLoop, xLoop, yLoop, zLoop As Integer
Dim vPos As Integer
Dim pRow As Long

pRow = tSht.Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim fs As New FileSystemObject
Dim fdr As Folder
Dim f As File

ChooseFolder strPath:=strPath
Set fdr = fs.GetFolder(strPath)

For Each f In fdr.Files
oldName(0) = f.Name
oldName(1) = (fdr & "\" & f.Name)
newName(0) = ""
newName(1) = ""

InputMes tVal:=tVal

vPos = 0
sP = Replace(f.Name, " ", "")
sP = Replace(sP, "_", "")

For xLoop = 1 To Len(sP)
    For nLoop = 0 To 9
        If Mid(UCase(sP), xLoop, 2) = "V" & nLoop Then
            vPos = xLoop
        End If
    Next nLoop
Next xLoop

**For yLoop = 1 To Len(sP)
If Mid(UCase(sP), yLoop, 3) = "SRV" Or Mid(UCase(sP), yLoop, 3) = "HRV" Then
        vPos = 99
    End If
Next yLoop**

**If vPos = 0 Then
    vPos = Application.Find(".", Right(sP, 5))
    If vPos = 1 Then
        newName(0) = Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, Len(sP) - 5)) & UCase(tVal) & "V01.00" & Trim(Mid(sP, Len(sP) - 4, 200))
        newName(1) = (fdr & "\" & Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, Len(sP) - 5)) & UCase(tVal) & "V01.00" & Trim(Mid(sP, Len(sP) - 4, 200)))
    End If
    If vPos = 2 Then
        newName(0) = Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, Len(sP) - 4)) & UCase(tVal) & "V01.00" & Trim(Mid(sP, Len(sP) - 3, 200))
        newName(1) = (fdr & "\" & Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, Len(sP) - 4)) & UCase(tVal) & "V01.00" & Trim(Mid(sP, Len(sP) - 3, 200)))
    End If
ElseIf vPos <> 99 Then
    If UCase(Trim(Mid(sP, vPos - 2, 3))) = "SRV" Or UCase(Trim(Mid(sP, vPos - 2, 3))) = "HRV" Then
        newName(0) = Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, vPos - 1)) & "V" & Trim(Mid(sP, vPos + 1, 200))
        newName(1) = (fdr & "\" & Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, vPos - 3)) & UCase(tVal) & "V" & Trim(Mid(sP, vPos + 1, 200)))
    Else
        newName(0) = Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, vPos - 1)) & UCase(tVal) & "V" & Trim(Mid(sP, vPos + 1, 200))
        newName(1) = (fdr & "\" & Format(f.DateCreated, "yyyy-mm-dd") & Trim(Mid(sP, 1, vPos - 1)) & UCase(tVal) & "V" & Trim(Mid(sP, vPos + 1, 200)))
    End If
End If**

If newName(1) = "" Then
    newName(0) = oldName(0)
End If

tSht.Cells(pRow, 1).Value = Format(Now, "dd/mm/yyyy")
tSht.Cells(pRow, 2).Value = fdr
tSht.Cells(pRow, 3).Value = Application.UserName
tSht.Cells(pRow, 4).Value = oldName(0)
tSht.Cells(pRow, 5).Value = newName(0)
pRow = pRow + 1

If newName(1) <> "" Then
    Name oldName(1) As newName(1)
End If

Next f

tSht.Activate

End Sub
Function InputMes(ByRef tVal As String)

Do Until tVal = "HR" Or tVal = "SR"
tVal = InputBox("Would you like all the files in the folder to become SR or HR? Please enter the value below")
    If tVal = "HR" Or tVal = "SR" Then
    Else
        tVal = ""
        MsgBox "Value entered is not HR or SR"
    End If
Loop

End Function
Function ChooseFolder(ByRef strPath As String)

Dim fd As FileDialog: Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim fdrChosen As Integer

fdrChosen = fd.Show
fd.InitialView = msoFileDialogViewList

If fdrChosen <> -1 Then
MsgBox "You chose cancel"
Else
strPath = fd.SelectedItems(1)
End If
End Function
Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.