VBA “folder” sorter

[Phoenix23]

Hi all I have been trying to make my life easier in work by trying to re organise the digital file store that is used on a shared network location. I know it’s possible to collate the information needed by pulling the data into excel and have this produce a list of files within a set location. I am having a problem however in having this show just the folders. Bit of background for this - the files for cases are named under a 7digit reference from one of the programs we use. These files are then stored in a folder under the same 7digit name, and these are stored in a folder consisting of 2 ranges e.g. 1000000 - 1000499, each one an increase of 500 from the previous. The problem I have noticed is that due to having over 4000 staff have access to this location is mistakes happen - and a lot have happened causing me to take over 2 days to manually relocate files into the correct range. The code I have tried was from a suggestion off one of the IT guys who has since retired and have no chance of external contact unfortunately. The code is below


Sub LoopFolder(ByVal folderPath As String)

Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long, iStartFolder As Long, iLastFolder As Long
Dim iPos1 As Byte, iPos2 As Byte, iPos3 As Byte


If Right(folderPath, 1) = "\" Then
folderPath = Mid(folderPath, 1, Len(folderPath) - 1)
iPos1 = InStrRev(folderPath, "-")
iPos2 = InStrRev(folderPath, "") + 1
iPos3 = iPos1 - iPos2

iStartFolder = Mid(folderPath, iPos2, iPos3)
iLastFolder = Mid(folderPath, iPos1 + 1, Len(folderPath) - iPos1)

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)

While Len(fileName) <> 0

If Left(fileName, 1) <> "." Then

fullFilePath = folderPath & fileName
fileName = Left(fileName, Len(fileName) - 4)

' If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
' ReDim Preserve folders(0 To numFolders) As String
' folders(numFolders) = fullFilePath
' numFolders = numFolders + 1
' Else
Select Case True
'Debug.Print folderPath & fileName
Case fileName >= iStartFolder And fileName <= iLastFolder
frmFileChecker.lbxFiles.AddItem fileName
Case Else
frmFileChecker.lbxTemp.AddItem fileName
Dim sNewFilepath As String
sNewFilepath = Mid(folderPath, 1, iPos2 - 1) & "Temp" & fileName & ".txt" ' have to adjust to correct Temp path
Name fullFilePath As sNewFilepath
End Select

' End If

End If

fileName = Dir()
Wend
End Sub

problem I’m getting is I can’t get it to work at all - any help would be amazing thanks in advance

[snb]

Please use code tags around VBA-code.

This macro can't be run on it's own.
It has to be 'called' by another macro.
That other macro needs also to indicate in a parameter which Folder has to be scrutinized.

[Phoenix23]

Thanks Snb, apologies for not using code markings was using my mobile to make the post yesterday when on the way home from work. And was struggling to see the functions for the text box. What would this initial coding need to look like and where would I reference in the above code ? Thanks

[snb]

There should be a macro somewhere like


Sub M_snb()
LoopFolder "G:\OF\"
End Sub

Post your sample workbook.

PS. You are the only one who is able to add the code tags in your initial post. Please do.

[Phoenix23]

Thanks for the basic script adjustment, due to it being on my work laptop I am unable to upload documents unless checked by Internal IT security even if it’s a blank workbook. If I could explain how the sheets are to look would that be any help ? Apologies but in process of upgrading personal laptop to have excel as haven’t had to use it in a few years so can upload that in a few days if that’s possible ?

[SamT]

This is compiled and tested as far as it goes. I assumed that the "" in your post was a VBAExpress Post Editor Autocorrect typo and replaced them with BackSlashes.

Sub LoopFolder(ByVal FolderPath As String)
'FolderPath like "1000000 - 1000499"

Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long, iStartFolder As Long, iLastFolder As Long
Dim iPos1 As Byte, iPos2 As Byte, iPos3 As Byte
dim TmpFldr '<-----------

'Fixed the Endless If
If Right(FolderPath, 1) = "\" Then FolderPath = Left(FolderPath, Len(FolderPath) - 1)

'this section would never work as written
'iPos1 = InStrRev(FolderPath, "-") 'Small number
'iPos2 = InStrRev(FolderPath, "\") + 1 'Big number
'iPos3 = iPos1 - iPos2 'Bad number
'iStartFolder = Mid(folderPath, iPos2, iPos3)
'iLastFolder = Mid(folderPath, iPos1 + 1, Len(folderPath) - iPos1)
'End bad section


'Replace bad section
TmpFldr = Split(FolderPath, "\")(0)
iStartFolder = Split(TmpFldr, " - ")(0)
iLastFolder = Split(TmpFldr, " - ")(1)


'add the \ back onto the Path
FolderPath = FolderPath & "\"



At that point, I would start using the Scripting FileSystemObject, and, do the cleanup in two Subs: Sub1) Move Case Folders; Sub2) Move Case Files. The FSO makes this simple. I would also consider doing both those in two parts: Part1) Write an excel report of what to move to where from where; Part2) Do the actual move. Can't be too careful with legal files.

I don't know how much influence you have over the filing system, but it sounds like someone merely copied an old Paper filing system, wherein File Drawers are limited in how much paper they can hold. Digital records don't have that limitation, a Single Folder/Directory can hold an unlimited number of sub-Directories or Files. If all your Case Folders were in the same Directory, (Case Files\,) there would never be an issue of them being in the wrong (1000000 - 1000499\) directory.

[Paul_Hossler]

Not 100% bullet proof




Option Explicit


Const sTopPath As String = "D:\Testing" ' no trailing backslash


'https://ss64.com/vb/filesystemobject.html
Sub MoveFilesAround()


Dim oFSO As Object
Dim oFolder As Object, oSubFolder As Object, oFile As Object
Dim sFolderLow As String, sFolderHigh As String, sFileBaseName As String, sFolderDest As String
Dim iFolderLow As Long, iFolderHigh As Long, iFileBaseName As Long

Set oFSO = CreateObject("Scripting.FileSystemObject")


For Each oSubFolder In oFSO.GetFolder(sTopPath).SubFolders

If Not oSubFolder.Name Like "#######-#######" Then GoTo NextSubfolder

sFolderLow = Left(oSubFolder.Name, 7)
sFolderHigh = Right(oSubFolder.Name, 7)

For Each oFile In oSubFolder.Files
sFileBaseName = oFSO.GetBaseName(oFile.Name)

If Not sFileBaseName Like "#######" Then GoTo NextFile
If sFolderLow <= sFileBaseName And sFileBaseName <= sFolderHigh Then GoTo NextFile



iFileBaseName = CLng(sFileBaseName)
iFolderLow = 1000 * Int(iFileBaseName / 1000) + 1
If iFileBaseName - iFolderLow > 500 Then iFolderLow = iFolderLow + 500
iFolderHigh = iFolderLow + 499

sFolderDest = sTopPath & Application.PathSeparator & Format(iFolderLow, "0000000") & "-" & Format(iFolderHigh, "0000000") & Application.PathSeparator

MsgBox oFile.Name & " will be moved to " & sFolderDest

If oFSO.FileExists(sFolderDest & Application.PathSeparator & oFile.Name) Then
oFSO.DeleteFile sFolderDest & Application.PathSeparator & oFile.Name, True
End If

oFSO.MoveFile oFile.Path, sFolderDest

NextFile:
Next


NextSubfolder:
Next


End Sub

[Phoenix23]

Thanks Snb, apologies for not using code markings was using my mobile to make the post yesterday when on the way home from work. And was struggling to see the functions for the text box. What would this initial coding need to look like and where would I reference in the above code ? Thanks

[Phoenix23]

Thanks for the help I’ll be giving this a go on Wednesday when back working have a few days off due to minor accident on way home yesterday, with your comment of the code stated “testing” can that be used as a cell reference in the spreadsheet ? Something like


= range(D1)

thanks again