D
Denise Pollock
I have pretty much no VBA knowledge. I found a code and modified it to work
for archiving some files, but I need to make more tweaks to it and I am not
sure what the commands would be. I need two If statements I believe...
Right now the macro takes all the files in the current folder, tags the
modified date to the end, and moves that file to the archive folder. Then
saves the active workbook in the current folder.
1.) The problem I have is, this same macro will exist in the archive version
and I don't want people to be able to run the macro from that folder. What
do I need to add to the code so when the macro is run and the active directy
is Archive, it will not run?
2.) I also need to update it so if there is a file in the archive folder
that has the same name it will add a 1 to the end of the file name.
Here is the code its really messy. Like I said I copied it so there were
pieces in it I didn't need so I just commented them to turn them off.
Sub Copy_and_Rename_To_New_Folder()
''MUST set reference to Windows Script Host Object Model in the project
using this code!
'This procedure will copy all files in a folder, and insert the last
modified date into the file name'
'it is identical to the other procedure with the exception of the
renaming...
'In this example, the renaming has utilized the files Last Modified
date to "tag" the copied file.
'This is very useful in quickly archiving and storing daily batch files
that come through with the same name on
'a daily basis. Note: All files in current folder will be copied this
way unless condition testing applied as in prior example.
Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
Dim objFile As File, strSourceFolder 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
Application.ScreenUpdating = False 'turn screenupdating off
Application.EnableEvents = False 'turn events off
'identify path names below:
strSourceFolder = "C:\current" 'Source path
strDestFolder = "C:\archive" 'destination path, does not have to exist
prior to execution
''''''''''NOTE: Path names can be strings built in code, cell
references, or user form text box strings''''''
''''''''''example: strSourceFolder = Range("A1")
'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
For Each objFile In objFolder.Files 'for every file in the folder...
'parse the name in three pieces, file name middle and extension.
In between, insert the
'last modified date. Other options may be a native Date function
or a cell refernce to
'tag the renamed file in place of
strName = Left(objFile.Name, Len(objFile.Name) - 4) 'remove
extension and leave name only
'strName = Range("A1") 'sample of renaming from cell A1, can by
used for strMid as well
strMid = Format(objFile.DateLastModified, "mm-dd-yy") 'insert and
format files date modified into name
'strMid = Format(Now(),"_mmm_dd_yy") 'sample of formatting the
current date into the file name
strExt = Right(objFile.Name, 4) 'the original file extension
strNewFileName = strName & strMid & strExt 'build the string file
name (can be done below as well)
'objFile.Copy strDestFolder & "\" & strNewFileName 'copy the file
with NEW name!
'objFile.Name = strNewFileName <====this can be used to JUST
RENAME, and not copy
'The below line can be uncommented to MOVE the files AND rename
between folders, without copying
objFile.Move strDestFolder & "\" & strNewFileName
'End If 'where conditional check, if applicable would be placed.
' Uncomment the If...End If Conditional as needed
Counter = Counter + 1
Next objFile 'go to the next file
MsgBox "Complete!"
'Message to user confirming completion
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
'clear the objects
ActiveWorkbook.Save
ChDir strSourceFolder
ActiveWorkbook.SaveAs Filename:= _
strSourceFolder & "\TESTShip.xls", _
FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
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 'exit sub here to avoid subsequent actions
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
for archiving some files, but I need to make more tweaks to it and I am not
sure what the commands would be. I need two If statements I believe...
Right now the macro takes all the files in the current folder, tags the
modified date to the end, and moves that file to the archive folder. Then
saves the active workbook in the current folder.
1.) The problem I have is, this same macro will exist in the archive version
and I don't want people to be able to run the macro from that folder. What
do I need to add to the code so when the macro is run and the active directy
is Archive, it will not run?
2.) I also need to update it so if there is a file in the archive folder
that has the same name it will add a 1 to the end of the file name.
Here is the code its really messy. Like I said I copied it so there were
pieces in it I didn't need so I just commented them to turn them off.
Sub Copy_and_Rename_To_New_Folder()
''MUST set reference to Windows Script Host Object Model in the project
using this code!
'This procedure will copy all files in a folder, and insert the last
modified date into the file name'
'it is identical to the other procedure with the exception of the
renaming...
'In this example, the renaming has utilized the files Last Modified
date to "tag" the copied file.
'This is very useful in quickly archiving and storing daily batch files
that come through with the same name on
'a daily basis. Note: All files in current folder will be copied this
way unless condition testing applied as in prior example.
Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
Dim objFile As File, strSourceFolder 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
Application.ScreenUpdating = False 'turn screenupdating off
Application.EnableEvents = False 'turn events off
'identify path names below:
strSourceFolder = "C:\current" 'Source path
strDestFolder = "C:\archive" 'destination path, does not have to exist
prior to execution
''''''''''NOTE: Path names can be strings built in code, cell
references, or user form text box strings''''''
''''''''''example: strSourceFolder = Range("A1")
'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
For Each objFile In objFolder.Files 'for every file in the folder...
'parse the name in three pieces, file name middle and extension.
In between, insert the
'last modified date. Other options may be a native Date function
or a cell refernce to
'tag the renamed file in place of
'if strMid is not used, it can be removed or left as a null "" string
strName = Left(objFile.Name, Len(objFile.Name) - 4) 'remove
extension and leave name only
'strName = Range("A1") 'sample of renaming from cell A1, can by
used for strMid as well
strMid = Format(objFile.DateLastModified, "mm-dd-yy") 'insert and
format files date modified into name
'strMid = Format(Now(),"_mmm_dd_yy") 'sample of formatting the
current date into the file name
strExt = Right(objFile.Name, 4) 'the original file extension
strNewFileName = strName & strMid & strExt 'build the string file
name (can be done below as well)
'objFile.Copy strDestFolder & "\" & strNewFileName 'copy the file
with NEW name!
'objFile.Name = strNewFileName <====this can be used to JUST
RENAME, and not copy
'The below line can be uncommented to MOVE the files AND rename
between folders, without copying
objFile.Move strDestFolder & "\" & strNewFileName
'End If 'where conditional check, if applicable would be placed.
' Uncomment the If...End If Conditional as needed
Counter = Counter + 1
Next objFile 'go to the next file
MsgBox "Complete!"
'Message to user confirming completion
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
'clear the objects
ActiveWorkbook.Save
ChDir strSourceFolder
ActiveWorkbook.SaveAs Filename:= _
strSourceFolder & "\TESTShip.xls", _
FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
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 'exit sub here to avoid subsequent actions
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