Parse and rename multiple .pdf files

A

ANDRE726

Joined
Feb 21, 2018
Messages
2
Reaction score
0
I have several hundred .pdf file and many have names as follows:
0000000123_ABCD (United States)_234_5678.pdf
I would like to rename this file, and others like it
0000000123_ABCD_234_5678.pdf
How may I accomplish this with vba?
Thanks in advance.
 
Here you are....
Thanks.ref: https://stackoverflow.com/questions...g-files-that-meet-specific-criteria-using-vba


Sub Tester()

Dim fls, f, crit
crit = "(UNITED STATES)" 'make appropriate changes on this line

Range("A1").Select

Set fls = GetFiles("D:\Amjad\VBA RND\", crit, "*.pdf") ' 'make appropriate changes on this line
For Each f In fls
ActiveCell = f
ActiveCell.EntireColumn.AutoFit
nf = Replace(f, crit, "")
If Trim(f) <> "" Then
FileCopy f, nf
ActiveCell.Offset(0, 1) = nf
ActiveCell.Offset(0, 1).EntireColumn.AutoFit
Kill f
ActiveCell.Offset(1, 0).Select
End If
Next f

End Sub



Function GetFiles(path As String, crit As Variant, Optional pattern As String = "") As Collection
Dim rv As New Collection, f
If Right(path, 1) <> "\" Then path = path & "\"
f = Dir(path & pattern)
Do While Len(f) > 0
If InStr(1, f, crit) Then
rv.Add path & f
Else
rv.Add " "
End If
f = Dir() 'no parameter

Loop

Set GetFiles = rv

End Function
 
If I am working with pdf files, where does the A1 select come in here? I am not working with excel files.
 
The code which I provide will get to those pdf files and will eventually rename them as you sought. but for this you will open a blank excel file and follow these steps:
1) press alt+F11
2) insert a module
3) Copy paste the following code and make appropriate changes in the red-highlighted lines
4) Run the code ...Tester

Sub Tester()

Dim fls, f, crit
crit = "(UNITED STATES)" 'make appropriate changes on this line

Range("A1").Select

Set fls = GetFiles("D:\Amjad\VBA RND\", crit, "*.pdf") ' 'make appropriate changes on this line
For Each f In fls
ActiveCell = f
ActiveCell.EntireColumn.AutoFit
nf = Replace(f, crit, "")
If Trim(f) <> "" Then
FileCopy f, nf
ActiveCell.Offset(0, 1) = nf
ActiveCell.Offset(0, 1).EntireColumn.AutoFit
Kill f
ActiveCell.Offset(1, 0).Select
End If
Next f

End Sub



Function GetFiles(path As String, crit As Variant, Optional pattern As String = "") As Collection
Dim rv As New Collection, f
If Right(path, 1) <> "\" Then path = path & "\"
f = Dir(path & pattern)
Do While Len(f) > 0
If InStr(1, f, crit) Then
rv.Add path & f
Else
rv.Add " "
End If
f = Dir() 'no parameter

Loop

Set GetFiles = rv

End Function
 
Back
Top