Good morning from NZ. I posted a question on this yesterday to do renaming/appending filename. I solved that.
The problem I now have is that the code is not copying and renaming files to the new folder and yet when I run to cursor past the filenaming iteration it appears to be doing that. Comes with the Error Handler code of 52 asking to make sure that files are not open or in use. Here is my full code hopefully with enough comments to understand the process.
I have bolded the possible offending code.
TIA.
(This is for approximately 30 files of multiple types/Ext and looking to do this 2 to 3 times a week to individual folders with specific dates for the files in that folder.)
The problem I now have is that the code is not copying and renaming files to the new folder and yet when I run to cursor past the filenaming iteration it appears to be doing that. Comes with the Error Handler code of 52 asking to make sure that files are not open or in use. Here is my full code hopefully with enough comments to understand the process.
I have bolded the possible offending code.
TIA.
(This is for approximately 30 files of multiple types/Ext and looking to do this 2 to 3 times a week to individual folders with specific dates for the files in that folder.)
Code:
Sub Copy_and_Rename_To_New_Folder_LH()
'Modified 24/11/15
'For H&S
Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
Dim objFile As File, strSourceFolder, Mnth, Dmnth, Yr, Dyr As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String, strNewFileName As String
Dim strName As String, strMid As String, strExt As String, val As String
Dim fn1, fn2 As String
Dim nL As Integer
Application.ScreenUpdating = False 'turn screenupdating off
Application.EnableEvents = False 'turn events off
strSourceFolder = "U:\Ant\WSMP Supreme Manual Master 2015\" 'Source path
val = Application.InputBox("Enter Company name", "Company Name Input")
strDestFolder = "U:\Ant\" & val & "\" 'destination path
'below will verify that the specified destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then 'if there is no error, continue below
PathExists = True 'if there is no error, set flag to TRUE
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
'message to alert that you may overwrite files of the same name since folder exists
If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
Else: 'if path does NOT exist, do the next steps
PathExists = False 'set flag at false
If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one
End If 'end the conditional testing
On Error GoTo ErrHandler
Set objFSO = New FileSystemObject 'creates a new File System Object reference
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder
Counter = 0 'set the counter at zero for counting files copied
If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section
[B] For Each objFile In objFolder.Files 'for every file in the folder...
'Filename to be repalced by variable
'InStrRev counts from the right
nL = InStrRev(objFile, ".")
'selects all the filename characters less Ext
fn2 = Left(objFile, nL - 1)
'adds the date on the end
fn2 = fn2 & " " & Format(Now(), "ddmmyyyy")
'adds the Ext to filename
fn2 = fn2 & Right(objFile, Len(objFile) - nL + 1)
objFile.Copy strDestFolder & fn2, False 'False = do not overwrite/ True = Overwrite if exist
'End If 'where conditional check, if applicable would be placed.
Counter = Counter + 1
Next objFile 'go to the next file[/B]
MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Exit Sub
NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
Exit Sub
ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"
Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End Sub
