• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 319
  • Last Modified:

More adjusting!

I have attached some VBA code that Rory kindly provided me, i have adjusted it for different reports and folders. This particular piece is constantly looping, it cant seem to find the file

My file directory is:G:\Asset Services MI\Sophis Fiscal breaks\2011\2 Feb 2011

The latest file is called

Sophis Fiscal 25022011.xls

Can anyone see from the code why this cant fin the file?

Thanks
Seamus
Sub OpenLatestFileSophisFiscal()
   Dim initPath As String, Direc As String, strFile As String, strFinalFile As String
   Dim DT As Date, dteFile As Date
   Dim objFSO, objFdr, objSubFdr
   
   ' Change Path of parent directory here
   ' Don't forget the "\" after the path
   initPath = "\\ukhibmdata02\rights\Asset Services MI\Sophis Fiscal breaks\2011\"
   
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set objFdr = objFSO.getfolder(initPath)
   
   ' loop through folders, checking names
   For Each objSubFdr In objFdr.subfolders
      If IsDate(objSubFdr.Name) Then
          If DT = #12:00:00 AM# Then
            DT = CDate(objSubFdr.Name)
            Direc = objSubFdr.Name
         Else
            If CDate(objSubFdr.Name) > DT Then
               DT = CDate(objSubFdr.Name)
               Direc = objSubFdr.Name
            End If
         End If
      End If
   Next objSubFdr
   ' check we found a date
   If Len(Trim(Direc)) <> 0 Then
      ' now need to loop through the files and find the last one
      ' assumes file names are like "09022011 Merit.xls"
      ' so we want the first 8 characters converted to a date
      strFile = Dir(initPath & Direc & "\*.xls")
      If strFile <> "" Then
         Do
            If dteFile < GetDateFromFileName(strFile) Then
               strFinalFile = strFile
               strFile = Dir
            End If
         Loop While strFile <> ""

         If Len(strFinalFile) > 0 Then
           Workbooks.Open initPath & Direc & "\" & strFinalFile
           Sheets("Check").Visible = True
           Sheets("Check").Select
         End If
         
         
      Else
         MsgBox "No workbooks in " & initPath & Direc & "\"
      End If
   Else
      MsgBox "No date files found"
   End If
End Sub

Function GetDateFromFileName(strFile As String) As Date
   ' returns date from last 8 characters of file name
   ' assumes ddmmyyyy format
   Dim dteTemp As Date, strTemp As String
   strTemp = Right$(Replace$(strFile, ".xls", "", , , vbTextCompare), 8)
   If Len(strTemp) < 8 Then Exit Function
   strTemp = Left$(strTemp, 2) & "/" & Mid$(strTemp, 3, 2) & "/" & Mid$(strTemp, 5, 4)
   If IsDate(strTemp) Then GetDateFromFileName = CDate(strTemp)
End Function

Open in new window

0
Seamus2626
Asked:
Seamus2626
1 Solution
 
McOzCommented:
Is it possible that your new file is an .xlsx?

In GetDateFromFileName, try replacing:

strTemp = Right$(Replace$(strFile, ".xls", "", , , vbTextCompare), 8)

with:

strTemp = Right$(Split(strFile, ".")(0), 8)

This will handle xlsx extensions as well as plain xls.

Good luck!
0
 
patrickabCommented:
Change this:

initPath = "\\ukhibmdata02\rights\Asset Services MI\Sophis Fiscal breaks\2011\"

So that it reflects the path to your files - namely:

G:\Asset Services MI\Sophis Fiscal breaks\2011\2 Feb 2011

Perhaps to this:

initPath = "G:\Asset Services MI\Sophis Fiscal breaks\2011\2 Feb 2011"
0
 
Rory ArchibaldCommented:
It works for me in a quick test.
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
Seamus2626Author Commented:
Hi McOz, not an xlsx file.

Patrick, thats not the problem either, its still looping away looking for the file.

Rorya, i take it you set up a dummy folder etc

Im gonna try and run my eyes carefully over it again, and if nothing, il post the ss and fodler names.

Thanks
Seamus
0
 
Seamus2626Author Commented:
Please see the two buttons that are marked red as the problem buttons.

The word doc shows a screenshot of the locations where those files are attempting to open the latest file, it also has shows the format of the excel file names.

I cannot see why the last two buttons wont open the latest files in those folders.

Any help would be much appreciated!

Thanks
Seamus
Example.xls
Doc1.doc
0
 
Rory ArchibaldCommented:
I've just tested the Sophis Fiscal one and it works fine for me. Have you tried stepping through the code to see where it is sticking?
0
 
Seamus2626Author Commented:
it loops through the below code infinately, it doesnt actually error

Seamus
If dteFile < GetDateFromFileName(strFile) Then
               strFinalFile = strFile
               strFile = Dir
            End If
         Loop While strFile <> ""

         If Len(strFinalFile) > 0 Then
           Workbooks.Open initPath & Direc & "\" & strFinalFile
           Sheets("Check").Visible = True
           Sheets("Check").Select
         End If
         
         
      Else
         MsgBox "No workbooks in " & initPath & Direc & "\"
      End If
   Else
      MsgBox "No date files found"
   End If
End Sub

Function GetDateFromFileName(strFile As String) As Date
   ' returns date from last 8 characters of file name
   ' assumes ddmmyyyy format
   Dim dteTemp As Date, strTemp As String
   strTemp = Right$(Replace$(strFile, ".xls", "", , , vbTextCompare), 8)
   If Len(strTemp) < 8 Then Exit Function
   strTemp = Left$(strTemp, 2) & "/" & Mid$(strTemp, 3, 2) & "/" & Mid$(strTemp, 5, 4)
   If IsDate(strTemp) Then GetDateFromFileName = CDate(strTemp)
End Function

Open in new window

0
 
Rory ArchibaldCommented:
It shouldn't do it indefinitely unless you have an infinite number of files.
Add this:
            Debug.Print "Processing: " & strFile

Open in new window

after the Do line (line 34 in the full code), so you can see in the immediate window which files it is processing.
0
 
Seamus2626Author Commented:
Tried that a cople of times Rory, in the editor and out of it, its just holding. The hourglass symbol is holding for ages, the only change i made to the files on one of the error buttons was that i made it a shared workbook, would that affect it?
0
 
Rory ArchibaldCommented:
Is it outputting any filenames to the immediate window? If not, then it's the folder part that is hanging it. Have you tried it using a drive letter rather than UNC path?
0
 
Seamus2626Author Commented:
No, nothing appears, i tried the code using the letter and the same result.

Fecking confused, because the pay rec one was working when i first ran that code when you gave it to me originally
0
 
Rory ArchibaldCommented:
If you are not seeing any filenames then I think it is caught up trying to find the right folder. When you step through it (using f8) where does it hang?
0
 
Seamus2626Author Commented:
Thats the thing, it doesnt hang when stepping through, it keeps looping and looping, its not hanfing anywhere when i step through using f8, it goes infinately between lines 34-64 (original posted code) and just keeps looping and looping.....
0
 
Rory ArchibaldCommented:
In that case you should be seeing filenames in the Immediate Window due to the code I asked you to add.
0
 
AndyAinscowFreelance programmer / ConsultantCommented:
        Do
            If dteFile < GetDateFromFileName(strFile) Then
               strFinalFile = strFile
               strFile = Dir
            End If
         Loop While strFile <> ""


IF strFile is not "" then it checks dteFile < GetDateFromFileName(strFile)
If dteFile >= GetDateFromFileName(strFile) then strFile is NOT CHANGED = infinite loop
0
 
Rory ArchibaldCommented:
Very good point, Andy. The strFile = Dir line should be after the End If not before.
0
 
Rory ArchibaldCommented:
PS Points to Andy, obviously! :)
0
 
Seamus2626Author Commented:
Sorry, was away from my desk. Perfect Andy, great spot.

Thank you to Rory.

Cheers
Seamus
0

Featured Post

Receive 1:1 tech help

Solve your biggest tech problems alongside global tech experts with 1:1 help.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now