Phoenix23
05-27-2021, 06:07 PM
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
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