Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
For removing a module/vba code before saving check out Chip Pearsons site look at the links at our forums http://www.thecodecage.com/forumz/extraresource.php -- The Code Cage Team Regards, The Code Cage Team www.thecodecage.com ------------------------------------------------------------------------ The Code Cage Team's Profile: http://www.thecodecage.com/forumz/member.php?userid=2 View this thread: http://www.thecodecage.com/forumz/sh...ad.php?t=23715 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
the code will create a new workbook and copy the old sheet into new sheet and
the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
Joel,
Thanks, but that code is giving me a Compile Error, saying variable is not defined, then it Highlights "First =" in the debugger. "Joel" wrote: the code will create a new workbook and copy the old sheet into new sheet and the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
Just add a delearation statement
Dim First as boolean Dim sht as Variant I couldn't tell from your posted code the options in VBA required all variables to be delared. "Denise Pollock" wrote: Joel, Thanks, but that code is giving me a Compile Error, saying variable is not defined, then it Highlights "First =" in the debugger. "Joel" wrote: the code will create a new workbook and copy the old sheet into new sheet and the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
then it stops on newbk, so I need to add..?
Dim newbk As ? "Joel" wrote: Just add a delearation statement Dim First as boolean Dim sht as Variant I couldn't tell from your posted code the options in VBA required all variables to be delared. "Denise Pollock" wrote: Joel, Thanks, but that code is giving me a Compile Error, saying variable is not defined, then it Highlights "First =" in the debugger. "Joel" wrote: the code will create a new workbook and copy the old sheet into new sheet and the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
Sorry, I missed that one
Dim newbk As Variant Variant will always work or leave the AS ? off "Denise Pollock" wrote: then it stops on newbk, so I need to add..? Dim newbk As ? "Joel" wrote: Just add a delearation statement Dim First as boolean Dim sht as Variant I couldn't tell from your posted code the options in VBA required all variables to be delared. "Denise Pollock" wrote: Joel, Thanks, but that code is giving me a Compile Error, saying variable is not defined, then it Highlights "First =" in the debugger. "Joel" wrote: the code will create a new workbook and copy the old sheet into new sheet and the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
That did it, thank you very much.
"Joel" wrote: Sorry, I missed that one Dim newbk As Variant Variant will always work or leave the AS ? off "Denise Pollock" wrote: then it stops on newbk, so I need to add..? Dim newbk As ? "Joel" wrote: Just add a delearation statement Dim First as boolean Dim sht as Variant I couldn't tell from your posted code the options in VBA required all variables to be delared. "Denise Pollock" wrote: Joel, Thanks, but that code is giving me a Compile Error, saying variable is not defined, then it Highlights "First =" in the debugger. "Joel" wrote: the code will create a new workbook and copy the old sheet into new sheet and the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Statement help
You may want to close the archieve workbook and the end of the code
ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False ActiveWorkbook.close "Denise Pollock" wrote: That did it, thank you very much. "Joel" wrote: Sorry, I missed that one Dim newbk As Variant Variant will always work or leave the AS ? off "Denise Pollock" wrote: then it stops on newbk, so I need to add..? Dim newbk As ? "Joel" wrote: Just add a delearation statement Dim First as boolean Dim sht as Variant I couldn't tell from your posted code the options in VBA required all variables to be delared. "Denise Pollock" wrote: Joel, Thanks, but that code is giving me a Compile Error, saying variable is not defined, then it Highlights "First =" in the debugger. "Joel" wrote: the code will create a new workbook and copy the old sheet into new sheet and the macro will not be copied. from ChDir strSourceFolder ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False to ChDir strSourceFolder First = true for each sht in activeworkbook.sheets if First = true then 'copy sheet into new workbook sht.copy set newbk = activeworkbook First = false else sht.copy after:=newbk.sheets(newbk.sheets.count) end if next sht ActiveWorkbook.SaveAs Filename:= _ strSourceFolder & "\TESTShip.xls", _ FileFormat:=xlNormal, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False "Denise Pollock" wrote: 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 =====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< '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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
IF statement inside a SUMIF statement.... or alternative method | Excel Worksheet Functions | |||
Reconcile Bank statement & Credit card statement & accounting data | Excel Worksheet Functions | |||
Embedding an OR statement in an IF statement efficiently | Excel Discussion (Misc queries) | |||
Sum if statement with a left statement | Excel Discussion (Misc queries) | |||
appending and IF statement to an existing IF statement | Excel Worksheet Functions |