Files move to a subfolder

Hi Leith Ross,

Thank you for trying to help me...
I try ur code but don.t move any file to the subfolder.

I try ur code but move every file and I want move all the files but not the files where is the code. And i need create the subfolder before run the code but i think i can turn around that "problem".

Hi shg,

Thk u 4 ur help. Ur code have a few froblems 4 what I want - I posted at 01:44 AM.
Thk u anyway

Yes, to both questions.

Hi, theres a few problems you face with the existing code...

1) the folder already exists when you try and make it
2) user enters an invalid folder name
3) code doesnt actually loop through files etc.

Heres 2 pieces of code - insert both into the VBE and then run the MoveExcelFiles sub

This function returns true if the folder name is acceptable to Windows or false if its not

Function ValidFolderName(strFolderName As Variant) As Boolean
Dim arrInvalidCharacters As Variant, arrItem As Variant
'Code by Graham Paramore

    'Folder names must not include the following: # % & * : <  > ? / \ { | }
    arrInvalidCharacters = Array("#", "%", "&", "*", ":", "<", ">", "?", "/", "\", "{", "|", "}")

    'First check if there is a string value passed
    If strFolderName = "" Then
        ValidFolderName = False
        Exit Function
    End If

    'Check if any invalid characters are there
    For Each arrItem In arrInvalidCharacters
        If InStr(1, strFolderName, arrItem, vbTextCompare) > 0 Then
            ValidFolderName = False
            Exit Function
        End If
    Next arrItem

    'Assign true indicating folder name should be OK
    ValidFolderName = True
End Function

This code copies over Excel files to your new subfolder

Sub MoveExcelFiles()
Dim objFileSystem As Object, obgFileList As Object, objFile As Object, GtName As Variant, ToFolder As String
Dim objSourceFolder As Object, strSourceFolder As String, strNewFilePath As String, strRawFileName As String
'Code by Graham Paramore

    'If theres an error then skip to the bottom and advise the error
    On Error GoTo ErrHandler

    'Assign a variable for the folder containing this workbook
    strSourceFolder = ThisWorkbook.Path

    'Ask user for folder name
    GtName = InputBox("Please Enter Subfolder Name", " Prog", Year(Now()) - 1)
    
    'Check user didn't click Cancel
    If GtName = "" Then
        MsgBox "You have not entered a folder name!", vbCritical, "Invalid FolderName"
        Exit Sub
    End If
    
    'Check folder name is valid.
    If ValidFolderName(GtName) = False Then
        MsgBox "You have not entered a valid folder name. A folder may not contain any of the following characters:" & _
            vbLf & "# % & * : <  > ? / \ { | }", vbCritical, "Invalid FolderName"
        Exit Sub
    End If
    
    'If folder doesn't already exist then create the folder
    ToFolder = ThisWorkbook.Path & "\" & GtName
    If Len(Dir(ToFolder, vbDirectory)) > 0 Then
        'Do nothing, folder is already there
    Else
        MkDir ToFolder
    End If
    
    'Create a FileSystemObject to work with the files
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    
    'Get a list of the filenames located in the same folder as this workbook
    Set objSourceFolder = objFileSystem.GetFolder(strSourceFolder)
    Set obgFileList = objSourceFolder.Files
    
    'Move each file to the new subfolder, but don't move this workbook.
    For Each objFile In obgFileList
            'This is the new path for the file
            strNewFilePath = ToFolder & "\" & objFile.Name

            'This is the file name without the path
            strRawFileName = objFile.Name

            'Only move xls files
            If Right(strRawFileName, 4) = ".xls" Or Right(strRawFileName, 5) = ".xlsx" Or Right(strRawFileName, 5) = ".xlsm" Then
                'Move over valid Excel files
                If Left(strRawFileName, 1) = "~" Or objFile.Path = ThisWorkbook.FullName Then
                    'Don't move this workbook or temp files.
                Else
                    'The file is ok so move it
                    objFileSystem.MoveFile objFile.Path, strNewFilePath
                End If
            End If
    Next objFile

    'Tidy up. Remove objects from memory
    Set objFileSystem = Nothing
    Set obgFileList = Nothing
    Set objFile = Nothing
    Set objSourceFolder = Nothing
    
    'Advise user that the files have been moved over
    MsgBox "The Excel files in the folder " & strSourceFolder & " have been successfully moved to the folder " & _
        ToFolder, vbInformation, "Move Files Was Successful"
    
    'Exit the sub so the error message doesn't display
    Exit Sub
    
ErrHandler:
    MsgBox "The following error occurred with the MoveExcelFiles Procedure:-" & _
        vbLf & vbLf & "Error#: " & vbLf & Err.Number & vbLf & "Description: " & _
        Err.Description, vbCritical, "Error in MoveExcelFiles Procedure", _
        Err.HelpFile, Err.HelpContext
    
End Sub

regards,
Graham