Rename and move files if something if not just move

[keaveneydan]

Hi

I am trying to come up with some code that will look at a file name and count the occurences of _
If it occurs more tan twice then I want to rename the file, removing the third _ and everything after it and move the file (or rather remove the last seven characters as after the third _ there are always six numbers)
If not then just move the file

I keep gettnig cmopile errors even though te code is taken from something else that works. I can't tell what i is that I have changed that is so critical

Can anyone help?

Thanks very much

Sub RenamePortFiles()
Application.DisplayAlerts = False
        Application.ScreenUpdating = False
Dim FilePath As String
Dim StopMacro As Boolean
Dim CurrentFile As String
Dim NewFileName As String
Dim FSO As New FileSystemObject
Dim aFile As File
Dim Count As Long

On Error GoTo ErrorHandler
    
    FilePath = "S:\Trading\End of Day\"
    If Len(Dir(FilePath & "Final EOD Files", vbDirectory)) = 0 Then
        MkDir (FilePath & "Final EOD Files")
    End If
    Do Until StopMacro = True
        CurrentFile = Dir(FilePath & "*.csv")
        If CurrentFile = "" Then
            MsgBox "No EOD trade files.", vbOKOnly + vbCritical, "No csv Files Found"
            Exit Sub
        End If
            Workbooks.Open Filename:=FilePath & CurrentFile
            Count = UBound(Split(CurrentFile, "_"))
            Set aFile = FSO.GetFile(FilePath & CurrentFile)
            If Count = 2 Then
            NewFileName = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 7)
            MsgBox NewFileName
            Else
            NewFileName = ActiveWorkbook.Name
            MsgBox NewFileName
            End If
            ActiveWorkbook.SaveAs Filename:=FilePath & "Final EOD Files\" & NewFileName
                Set aFile = Nothing
            ActiveWorkbook.Close
        Kill FilePath & CurrentFile
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    
ErrorHandler:
If Err.Number <> 0 Then
Msg = Str(Err.Number)
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Resume Next
    
    Application.DisplayAlerts = True
        Application.ScreenUpdating = True
End Sub

 

[keaveneydan]

OK solved it but not really

I am missing a reference to Microsoft scripting runtime

I have it in another workbook but cannot get it into this workbook

It is not on the reference list

Have tried manually opening SCRRUN.DLL but nothing

My solution was to move everything from workbook that hasn't got it to workbook that has got it...not ideal

Thanks