Solved: Renaming / Reorganizing files / directories

[Anne Troy]

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


[VBA]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
[/vba]

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]

[VBA]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[/VBA]

[Anne Troy]

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]

You're in a good mood Anne.

[Anne Troy]

LOL

[Anne Troy]

I am still using this macro at least weekly. I love it. Thank you!!

[Kenneth Hobs]

Glad it worked out for you Anne.

You can remove the Function part if you like.
[VBA]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[/VBA]