Excel VBA Renaming Files to Cell Name

[Dmack21]

Good day,

Very new to visual basic and have had very little success attempting to achieve the following.

Ive got a series of *.dwg files saved in the same location as the spreadsheet named as follows:

STXX-XXX-X-BBBBBBB.dwg
STXX-XXX-X-CCCCCCC.dwg
STXX-XXX-X-DDDDDD.dwg

I would like the files renamed with STXX-XXX* being replaced with the contents of Cell D4 (Example "ST99-999").

ST99-999-X-BBBBBBB.dwg
ST99-999-X-CCCCCCC.dwg
ST99-999-X-DDDDDD.dwg

Would this be possible to achieve? If so, can I please get some guidance?

Thanks in advance.

 

[ranman256]

paste the code into a module,

in this example:
Range("B1").Value ,has the folder to use to rename files. (change or hardcode this folder valu)
Range("D4").Value , has the number to rename to.
then run: RenameAllFiles1Folder

Option Explicit
Sub RenameAllFiles1Folder()
Dim vDir
vDir = Range("B1").Value
If vDir = "" Then Exit Sub
Range("A3").Select
RenameAllFiles vDir
End Sub

Private Sub RenameAllFiles(ByVal pvDir)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String
Dim vNewName, vMid, vNew, vPattern, vCellVal, vWord
Const kiNUM = 2
vCellVal = Range("D4").Value
vWord = "ST" & vCellVal & "-" & vCellVal
vPattern = ".xls"
'vPattern = ".dwg"
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
pvDir = FixDir(pvDir)
For Each oFile In oFolder.Files
 
  If vPattern = "" Then
     GoSub RenameIt
  ElseIf InStr(oFile.Name, vPattern) > 0 Then
     GoSub RenameIt
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Exit Sub
RenameIt:
    vMid = Mid(oFile.Name, 9)
    vNewName = pvDir & vWord & vMid
  
    Name oFile As vNewName
      
       'track changes
    Debug.Print vNewName
    'ActiveCell.Value = vNewName
    'ActiveCell.Offset(1, 0).Select
Return
End Sub
Public Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

 

[JEC]

How about? Current names starting in A4 and replacements in D4

Sub jec()
Dim it
For Each it In Range("A4", Range("A" & Rows.Count).End(xlUp))
  Name ThisWorkbook.Path & "\" & it As ThisWorkbook.Path & "\" & Left(it.Offset(, 3), 8) & Mid(it, 9)
Next
End Sub

 

[Dmack21]

paste the code into a module,

in this example:
Range("B1").Value ,has the folder to use to rename files. (change or hardcode this folder valu)
Range("D4").Value , has the number to rename to.
then run: RenameAllFiles1Folder

Option Explicit
Sub RenameAllFiles1Folder()
Dim vDir
vDir = Range("B1").Value
If vDir = "" Then Exit Sub
Range("A3").Select
RenameAllFiles vDir
End Sub

Private Sub RenameAllFiles(ByVal pvDir)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String
Dim vNewName, vMid, vNew, vPattern, vCellVal, vWord
Const kiNUM = 2
vCellVal = Range("D4").Value
vWord = "ST" & vCellVal & "-" & vCellVal
vPattern = ".xls"
'vPattern = ".dwg"
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
pvDir = FixDir(pvDir)
For Each oFile In oFolder.Files
 
  If vPattern = "" Then
     GoSub RenameIt
  ElseIf InStr(oFile.Name, vPattern) > 0 Then
     GoSub RenameIt
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Exit Sub
RenameIt:
    vMid = Mid(oFile.Name, 9)
    vNewName = pvDir & vWord & vMid
 
    Name oFile As vNewName
     
       'track changes
    Debug.Print vNewName
    'ActiveCell.Value = vNewName
    'ActiveCell.Offset(1, 0).Select
Return
End Sub
Public Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

Hi ranman,

Thank you so much for the assistance!! Great skills...The above code worked well!

Regards.

 

[Dmack21]

How about? Current names starting in A4 and replacements in D4

Sub jec()
Dim it
For Each it In Range("A4", Range("A" & Rows.Count).End(xlUp))
  Name ThisWorkbook.Path & "\" & it As ThisWorkbook.Path & "\" & Left(it.Offset(, 3), 8) & Mid(it, 9)
Next
End Sub

Thank you for your input. I was unable to utilise this code, being a new user Its more than likely a user error. Ranmans solution has done the job.

Regards

 

[Dmack21]

paste the code into a module,

in this example:
Range("B1").Value ,has the folder to use to rename files. (change or hardcode this folder valu)
Range("D4").Value , has the number to rename to.
then run: RenameAllFiles1Folder

Option Explicit
Sub RenameAllFiles1Folder()
Dim vDir
vDir = Range("B1").Value
If vDir = "" Then Exit Sub
Range("A3").Select
RenameAllFiles vDir
End Sub

Private Sub RenameAllFiles(ByVal pvDir)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String
Dim vNewName, vMid, vNew, vPattern, vCellVal, vWord
Const kiNUM = 2
vCellVal = Range("D4").Value
vWord = "ST" & vCellVal & "-" & vCellVal
vPattern = ".xls"
'vPattern = ".dwg"
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
pvDir = FixDir(pvDir)
For Each oFile In oFolder.Files
 
  If vPattern = "" Then
     GoSub RenameIt
  ElseIf InStr(oFile.Name, vPattern) > 0 Then
     GoSub RenameIt
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Exit Sub
RenameIt:
    vMid = Mid(oFile.Name, 9)
    vNewName = pvDir & vWord & vMid
 
    Name oFile As vNewName
     
       'track changes
    Debug.Print vNewName
    'ActiveCell.Value = vNewName
    'ActiveCell.Offset(1, 0).Select
Return
End Sub
Public Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

Good day Ranman,

The above code is working great and being successfully utilised.

The above code successfully filters all *.dwg files and renames them. I am now attempting to only rename dwg files in the folder which begin with an "X".

Ive had many unsuccessfull hours thus far..

Thanks in advance.

 

[ranman256]

If InStr(oFile.Name, ".dwg") > 0 and ucase(left(ofile.name,1)) = "X" then

 

[Dmack21]

If InStr(oFile.Name, ".dwg") > 0 and ucase(left(ofile.name,1)) = "X" then

Thanks ranman, highly appreciated!