PDA

View Full Version : Solved: Renaming / Reorganizing files / directories



Anne Troy
10-16-2008, 06:13 AM
I would love Excel to rearrange the files in a directory.

Sample FROM list of files

2202-2.pdf
2234.pdf
2235.pdf
2237.pdf
2238.pdf
2239-1.pdf
2242.pdf
1333-1.pdf

Sample TO list of files/folders:

2234 (this is a folder)
....2234.pdf (this is the file, now within the folder)
2235
....2235.pdf
2237
....2237.pdf
2238
....2238.pdf
2242
....2242.pdf
1333-1.pdf (nothing has been done with these)
2202-2.pdf
2239-1.pdf


Private Sub Workbook_Open()
'Do the folder making
On Error GoTo
'A message box that says "This operation has aborted due to file naming error(s)."
'and no folders should be made at all
End Sub


Acceptable filename formats:

nnnn.pdf
nnnn-n.pdf


The path, which I'd like to be able to change IN THE CODE, is:
P:\Stock Room

If we need the name of the server, let's call it MyServer


Thanks sooooo much!!!

Help! :)

Kenneth Hobs
10-16-2008, 07:30 AM
Sub MovePDFs()
Dim fName As String, myFolder As String, fileName As String
Dim p1 As Integer, p2 As Integer
myFolder = "P:\Stock Room\" 'Trailing backslash needed

If Dir(myFolder, vbDirectory) = "" Then Exit Sub
fileName = myFolder & Dir(myFolder & "*.pdf")
Do While fileName <> myFolder
If InStr(fileName, "-") = 0 Then
p1 = InStrRev(fileName, "\") + 1
p2 = InStrRev(fileName, ".") - p1
fName = Mid(fileName, p1, p2)
If FolderExists(myFolder & fName) = False Then
MkDir myFolder & fName
End If
Name fileName As (myFolder & fName & "\" & fName & ".pdf")
End If
fileName = myFolder & Dir
Loop
End Sub

Function FolderExists(sFolder As Variant) As Boolean
Dim fso As Object
Dim tf As Boolean
Set fso = CreateObject("Scripting.FileSystemObject")
tf = fso.FolderExists(sFolder)
Set fso = Nothing
FolderExists = tf
End Function

Anne Troy
10-16-2008, 07:41 AM
You, sir, are the BOMB. That's incredible, perfect. You're a gentleman and a scholar, and your generosity is exceeded ONLY by your extremely good looks!

Aussiebear
10-16-2008, 01:36 PM
You're in a good mood Anne.

Anne Troy
10-20-2008, 05:51 AM
LOL

Anne Troy
05-26-2009, 09:01 AM
I am still using this macro at least weekly. I love it. Thank you!!

Kenneth Hobs
05-26-2009, 12:42 PM
Glad it worked out for you Anne.

You can remove the Function part if you like.
Sub MovePDFs()
Dim fName As String, myFolder As String, fileName As String
Dim p1 As Integer, p2 As Integer
myFolder = "P:\Stock Room\" 'Trailing backslash needed

If Dir(myFolder, vbDirectory) = "" Then Exit Sub
fileName = myFolder & Dir(myFolder & "*.pdf")
Do While fileName <> myFolder
If InStr(fileName, "-") = 0 Then
p1 = InStrRev(fileName, "\") + 1
p2 = InStrRev(fileName, ".") - p1
fName = Mid(fileName, p1, p2)
If Dir(myFolder & fName, vbDirectory) = "" Then
MkDir myFolder & fName
End If
Name fileName As (myFolder & fName & "\" & fName & ".pdf")
End If
fileName = myFolder & Dir
Loop
End Sub