I want to create a bit of code that saves a file out to a folder (PDF / DWG ) and moves all my files with a lower revision #5 than the current file being saved into a superseded folder.
I cannot see how to set a condition for the revision number: I can't use a wildcard as that would cause issues as other files in the folder would be picked up and moved incorrectly.
I have the save function sorted, I just dont know were to start with filing part.
Examples of the filenames:
Pdf/TE1801_200-01_{name}_#5.PDF
Dwg/TE1801_200-01_{name}_#5.DWG
You could use the GetBaseName Method to get just the filename without the extension
Then use the INSTRREV Function to find the position of the last "#" (just in case someone used a "#" in the {name} part).
Next use the LEFT Function to get the the "TE1801_200-01_{name}_#" part and now you can add a wildcard to it like "TE1801_200-01_{name}_#*.*". (It doesn't matter whether or not you have the "#" at the end at this stage.)
Prepend the full path and get all the matching files.
Move those files.
Now save the current file with its revison number.
' ------------------------------------------------------------------------------
' MOVE OLD REVISION TO SUPERSEDED FOLDERS - PDF
' ------------------------------------------------------------------------------
URLPASS = Filepath & "PDF\"
Dim MyObj As Object, MySource As Object, file As Variant
Set MyObject = CreateObject("Scripting.FileSystemObject")
Set MySource = MyObject.GetFolder(URLPASS)
For Each file_ In MySource.Files
LArray = Split(file_, "#")
checkfile = LArray(0)
REV = Split(LArray(1), ".")
If LArray(0) = checkfile And REV(0) < VERSION Then
' FILE FORMATING
' ----------------------------------------
RECON = Split(file_, "PDF\")
file_ = RECON(1)
RECON = Split(file_, ".")
DRAWNOCONFIG = RECON(0)
' MOVE TO NEW LOCATION
' ----------------------------------------
If Dir(Filepath & "PDF" & "\SUPERSEDED", vbDirectory) = "" Then '
MkDir Filepath & "PDF" & "\SUPERSEDED"
End If
Name Filepath & "PDF\" & DRAWNOCONFIG & ".pdf" As Filepath & "PDF\" & "SUPERSEDED\" & DRAWNOCONFIG & ".pdf"
Else
'DO NOTHING
GoTo Endline
End If
Endline:
Next file_
' ------------------------------------------------------------------------------
' MOVE OLD REVISION TO SUPERSEDED FOLDERS - DWG
' ------------------------------------------------------------------------------
URLPASS = Filepath & "DWG\"
Set MyObject = CreateObject("Scripting.FileSystemObject")
Set MySource = MyObject.GetFolder(URLPASS)
For Each file_ In MySource.Files
LArray = Split(file_, "#")
checkfile = LArray(0)
REV = Split(LArray(1), ".")
If LArray(0) = checkfile And REV(0) < VERSION Then
' FILE FORMATING
' ----------------------------------------
RECON = Split(file_, "DWG\")
file_ = RECON(1)
RECON = Split(file_, ".")
DRAWNOCONFIG = RECON(0)
' MOVE TO NEW LOCATION
' ----------------------------------------
If Dir(Filepath & "DWG" & "\SUPERSEDED", vbDirectory) = "" Then '
MkDir Filepath & "DWG" & "\SUPERSEDED"
End If
Name Filepath & "DWG\" & DRAWNOCONFIG & ".dwg" As Filepath & "DWG\" & "SUPERSEDED\" & DRAWNOCONFIG & ".dwg"
Else
'DO NOTHING
GoTo Endline2
End If
Endline2:
Next file_
Related
I have been trying to move over 300+ pdf files to subfolders, which partially match filenames. The file names format is as follow:
Definition, PN 123456, SN unique
Definition(may change), PN 657634(may change), SN unique(always different)
Their pattern is two commas followed by PN and SN: ..., PN ..., SN ...
The folder names are: PN 123456 SN unique.
The example:
filenames
VALVE AFT SAFETY, PN 81155B010101, SN 00515
CABIN PRESSURIZATION MODULE, PN 92147A020103, SN 00501
AIR CYCLE MACHINE, PN 820906-3, SN 2010010011
AIR CYCLE MACHINE, PN 820906-3, SN 2010010014
TEMP REDUCTION SWITCH, PN 820907-2, SN 0414
folder names
PN 81155B010101 SN 00515
PN 92147A020103 SN 00501
PN 820906-3 SN 2010010011
PN 820906-3 SN 2010010014
PN 820907-2 SN 0414
The folders are subdirectories, second level.
I tried the information that, was kindly provided by #BNR bnr.455560 here: https://www.mrexcel.com/board/threads/moving-files-to-a-subfolder-based-on-partial-filename-with-vba.1120135/
My original post: https://www.mrexcel.com/board/threads/moving-files-to-a-subfolder-based-on-partial-filename-with-vba.1221014/
The below code run as Macro - does nothing.
Public Function Return_SubDirectory_Name(FileName As String) As String
'define a string array
Dim Splitter() As String
' check if we have a filename with a length > 0 - i.e. no empty filenames
If Len(FileName) > 0 Then
' let's assume the filename is "Definition, PN 123456, SN unique.pdf"
' Split creates a string array with the ", " as the break point - notice the space before and after the "-" character
' element 0 in the array will hold "Definition"
' element 2 in the array will hold "SN inique.pdf
Splitter = Split(FileName, ", ", 2)
' test to make sure the array has JUST two elements
' 1st element of ANY array starts with zero
' logic would need to be adjusted if file name was something like "02 - 12345 - 123.pdf" - as plsit function would create more elements
If UBound(Splitter) = 1 Then
' now splitter (1) holds the value "PN 123456, SN unique.pdf"
' split out the ".pdf" or whatever file extention
Splitter = Split(Splitter(1), ".")
' element (0) now just holds "PN 123456, SN unique" - this *SHOULD* be the sub directory or deal #
'Remove comma "," by replace it to ""
Splitter = Replace(Splitter(0), ",", "")
Return_SubDirectory_Name = CStr(Splitter(0))
' now exit the function
Exit Function
End If
' if above logic didn't work (maybe weird file name or whatever) - then drop out here with vbnullstring (empty) filename
Return_SubDirectory_Name = vbNullString
End If
End Function
Public Sub Check_Files(Search_Path As String)
Dim File_Name As String
Dim File_Type As String
Dim strFileName As String
Dim Deal_Name As String
Dim Archive_Path As String
Dim Target_Path As String
Dim File_Count As Integer
' setup where the archive directory is - maybe a network location?
' I'll assume it is the same directory path as the work book - change the following path as required
' path should be in a format like "C:\Desktop\MyFiles" or something
Archive_Path = ThisWorkbook.Path
' the search_path is handed into the function as an argument
' checks the Search path - this path is where the file currently are - maybe different than where you want to archive them
Confirm_Directory Search_Path
' changes excel's default directory path to the one you want to search
ChDir Search_Path
' assumes .msg files, but could be .pdf files - make changes as needed
File_Type = Search_Path & "*.pdf"
' identifies file name within the target directory
strFileName = Dir(File_Type)
' cycles through each file within the search directory - will continue until the length of the strFileName = 0 (i.e. no files)
Do While Len(strFileName) > 0
' get the sub directory or #deal name
Deal_Name = Return_SubDirectory_Name(strFileName)
' test if we have a valid deal name (not a vbnullstring)
If Len(Deal_Name) > 0 Then
' update the target_path - the target path will change as the different #deal name subdirectories within the archive path change
Target_Path = Archive_Path & "\" & Deal_Name
' checks if THAT target archive path exists - makes one if it doesn't
Confirm_Directory Target_Path
' copy required file to the target archive directory
FileCopy Search_Path & "\" & strFileName, Target_Path & "\" & strFileName
' delete original copy from search directory
Kill Search_Path & "\" & strFileName
File_Count = File_Count + 1
End If
' aquires the next filename in the search directory
strFileName = Dir
Loop
Debug.Print "Moved " & File_Count & " file(s)"
End Sub
Public Sub Confirm_Directory(This_Path As String)
' used to test for directory locations
' will make sub directories if required
Dim Splitter() As String
Dim Test_Path As String
If Dir(This_Path, vbDirectory) <> vbNullString Then
Splitter = Split(This_Path, "\")
For I = LBound(Splitter) To UBound(Splitter)
If I = 0 Then
Test_Path = Splitter(0)
Else
Test_Path = Test_Path & "\" & Splitter(I)
End If
ReTest:
If Dir(Test_Path, vbDirectory) = vbNullString Then
'Debug.Print "'" & Test_Path & "' does not exist"
MkDir Test_Path
'Debug.Print "Making ' " & Test_Path & "'"
GoTo ReTest
Else
'Debug.Print "'" & Test_Path & "' exists"
End If
Next I
End If
End Sub
Sub Sort_files_2_folders_()
End Sub
Try this out (adjust file paths as needed)
Sub RelocateFiles()
Dim allFiles As Collection 'of File objects
Dim allFolders As Collection 'of Folder objects
Dim f As Object, fld As Object, sn As String, bMoved As Boolean
'find all files (include subfolders)
Set allFiles = GetFiles("C:\Temp\TestFiles\", "*.pdf", True)
'find all destination folders
Set allFolders = GetFolders("C:\Temp\TestFiles\", True)
For Each f In allFiles 'loop over files
sn = GetSN(f.Name) 'get SN part of name
bMoved = False 'reset flag
If Len(sn) > 0 Then 'has "sn" part ?
For Each fld In allFolders 'loop over folders
If GetSN(fld.Name) = sn Then 'check folder name
Debug.Print "Moving '" & f.Name & _
"' to '" & fld.Path & "'"
f.Move fld.Path & "\" 'move the files
bMoved = True 'flag moved
Exit For 'stop checking
End If
Next fld
End If
If Not bMoved Then Debug.Print "## Not moved: " & f.Name
Next f
End Sub
'Return the "sn" part for a folder or file name
Function GetSN(txt As String) As String
Dim arr, sn, pos As Long
arr = Split(txt, " SN ")
If UBound(arr) > 0 Then
sn = arr(UBound(arr))
pos = InStr(sn, ".") 'any extension? (if a filename)
If pos > 0 Then sn = Left(sn, pos - 1) 'remove extension
GetSN = sn
End If
End Function
'Find all folders under `startFolder`
' Returns a collection of Folder objects
Function GetFolders(startFolder As String, _
Optional subFolders As Boolean = True) As Object
Dim fso, fldr, f, subFldr, fpath
Dim colFolders As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
For Each subFldr In fldr.subFolders
If subFolders Then colSub.Add subFldr.Path
colFolders.Add fso.getfolder(subFldr.Path)
Next subFldr
Loop
Set GetFolders = colFolders
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFiles(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fso.getfile(fpath & f)
f = Dir()
Loop
Loop
Set GetFiles = colFiles
End Function
I have working code to:
Insert the Date, Company Name & Order Number into the proof at a specific location (data is pulled from the file location "C:\2020\My Company\Company Name\COM001 - 01\Layouts")
Determine the amount of pages in the document
Paste step 1 onto the other pages
Export the document as a .pdf
What I am trying to achieve, is before the .pdf is saved that the file is renamed (in this case COM001 - 01) adds a version indicator (" _v1") then saves the .cdr file and then runs the .pdf export function but does not overwrite the original.
I have been trying to adapt code I found on thespreadsheetguru.
The code adds the version indicator and exports the .pdf in the correct file location, but as soon as I open another file in a different location it will save it in the previous location instead.
Here is that piece of code: (I can upload the entire code if needed.)
Private Sub SaveNewVersion()
'PURPOSE: Save file, if already exists add a new version indicator to filename
Dim FolderPath, myPath, SaveName, SaveExt, VersionExt As String
Dim Saved As Boolean
Dim x As Long
Saved = False
x = 1
'Version Indicator (change to liking)
VersionExt = " _v"
'Pull info about file
On Error GoTo NotSavedYet
myPath = ActiveDocument.FileName
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
'Determine Base File Name
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
'Need a new version made
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveDocument.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
Exit Sub
'Error Handler
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
I have a feeling the code is messing up in the "pull info about file section".
You need to store the final path in a way that you can inspect it before you use it. Swap out this block of code here:
Dim newFileName as String
newFileName = FolderPath & SaveName & VersionExt & x & SaveExt
Debug.Print newFileName
If FileExist(newFileName) = False Then
ActiveDocument.SaveAs newFileName
Saved = True
Else
x = x + 1
End If
This will print the final filename to the Immediate Window before the save happens. If it is incorrect, change newFileName to be whatever you want.
Turns out it was a simple issue regarding the File path not returning any information..
changed out this code and now it works perfectly
On Error GoTo NotSavedYet
myFile = ActiveDocument.FileName
myPath = (ActiveDocument.FilePath)
myFileName = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myFile, Len(myFile) - InStrRev(myFile, "."))
Debug.Print FolderPath
On Error GoTo 0
Thanks #HackSlash for the tip, much appreciated
I need to copy my server log file to another folder up on completion of one log file and then rename the copied file adding date and time to the file name.
Source : C:\Server\Logs
Destination : Can be selected by user using .BrowseForFolder
Log file name : Server_log_23.txt ("23" is the log number which will change from 1 to 30)
One log file will be completed in 2 minutes and log writing will be moved to next file by adding one (that means if Server_log_23.txt is completed then server will starts writing logs in Server_logs_24.txt till Server_log_30.txt, if log_30 is completed then it will starts writing in log_1)
I got a code like this, but it is not giving a continuous loop
Const DestinationFile = "C:\Users\Testbench\Desktop\file copy\Destination\"
Const src = "C:\Users\Testbench\Desktop\file copy\Source\"
strInput = UserInput( "Please enter file number:" )
strInput1 = "log_(" &strInput1 &")"
Dim sDateTimeStamp
Dim folder
Sub CopyFile()`enter code here`
Set fso = CreateObject("Scripting.FileSystemObject")
srcfile = strInput
Set folder = fso.GetFolder(src)
For Each file In folder.files
If instr(file.name, strInput) > 0 Then
srcfile=file.name
WScript.Echo srcfile
End If
Next
SourceFile= "C:\Users\Testbench\Desktop\file copy\Source\" & srcfile
WScript.Echo SourceFile
sDateTimeStamp = cStr(Year(now())) & _
Pad(cStr(Month(now())),2) & _
Pad(cStr(Day(now())),2) & _
Pad(cStr(Hour(now())),2) & _
Pad(cStr(Minute(now())),2) & _
Pad(cStr(Second(now())),2)
WScript.Echo "Copying " & SourceFile & " to " & DestinationFile
fso.CopyFile SourceFile, DestinationFile & srcfile & "_" & sDateTimeStamp & ".txt", True
Set fso = Nothing
End Sub
Function Pad(CStr2Pad, ReqStrLen)
Dim Num2Pad
Pad = CStr2Pad
If len(CStr2Pad) < ReqStrLen Then
Num2Pad = String((ReqStrlen - Len(CStr2Pad)), "0")
Pad = Num2Pad & CStr2Pad
End If
End Function
Function UserInput( myPrompt )
If UCase( Right( WScript.FullName, 12 ) ) = "\CSCRIPT.EXE" Then
WScript.StdOut.Write myPrompt & " "
UserInput = WScript.StdIn.ReadLine
Else
UserInput = InputBox( myPrompt )
End If
End Function
Do while strInput1<30
wscript.sleep 180
CopyFile()
strInput1 = strInput1 + 1
Exit Do
strInput1 =1
CopyFile()
strInput1 = strInput1 + 1
Loop
I found some VBA routines here in and I tried to adapt them to my situation.
It works fine but when I try to copy a file to a folder that has been created using in its name a constant “process” and a variable [ID] field, I get an error message.
The error is in this line
FileCopy f.SelectedItems(i), "O:\docs\process\ " & (me.ID)
Private Sub Comando356_Click()
' lets say my current record has an ID field value 345
' The routine will check if folder O:\docs\process345 exists
' If the folder does not exist, then the folder is created:
If
Len(Dir("O:\docs\process" & (Me.ID), vbDirectory)) = 0 Then
MkDir "O:\docs\process" & (Me.ID)
End If
‘ So far it works perfectly: if the folder does not exist, is created
Dim f As Object
Set f = Application.FileDialog(3)
f.AllowMultiSelect = False
If f.Show Then
For i = 1 To f.SelectedItems.Count
sFile = Filename(f.SelectedItems(i), sPath)
' My problem is the next line: folder O:\docs\process345 exists but I get an error 76 “Path not Found”
FileCopy f.SelectedItems(i), "O:\docs\process" & (me.ID)
Next
End If
End Sub
Public Function Filename(ByVal strPath As String, sPath) As String
sPath = Left(strPath, InStrRev(strPath, "\"))
Filename = Mid(strPath, InStrRev(strPath, "\") + 1)
End Function
add a Slash and add the FileName
Private Sub Comando356_Click()
' lets say my current record has an ID field value 345
' The routine will check if folder O:\docs\process345 exists
' If the folder does not exist, then the folder is created:
If
Len(Dir("O:\docs\process" & (Me.ID), vbDirectory)) = 0 Then
MkDir "O:\docs\process" & (Me.ID)
End If
‘ So far it works perfectly: if the folder does not exist, is created
Dim f As Object
Set f = Application.FileDialog(3)
f.AllowMultiSelect = False
If f.Show Then
For i = 1 To f.SelectedItems.Count
sFile = Filename(f.SelectedItems(i), sPath)
' My problem is the next line: folder O:\docs\process345 exists but I get an error 76 “Path not Found”
' add some debugging
Debug.Print ("in=" & f.SelectedItems(i) & " out=" & "O:\docs\process" & (me.ID) & "\" & sFile)
' add a Slash and add the FileName
FileCopy f.SelectedItems(i), "O:\docs\process" & (me.ID) & "\" & sFile ' <<<<
Next
End If
End Sub
Public Function Filename(ByVal strPath As String, sPath) As String
sPath = Left(strPath, InStrRev(strPath, "\"))
Filename = Mid(strPath, InStrRev(strPath, "\") + 1)
End Function
I have this code which finds file names(along with file paths) based on search string.This code works fine in finding single files. I would like this macro to find multiple files and get their names displayed separated using a comma.
Function FindFiles(path As String, SearchStr As String)
Dim FileName As String ' Walking filename variable.
Dim DirName As String ' SubDirectory Name.
Dim dirNames() As String ' Buffer for directory name entries.
Dim nDir As Integer ' Number of directories in this path.
Dim i As Integer ' For-loop counter.
Dim Name As String
Dim Annex As String
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly _
Or vbSystem) ' Even if hidden, and so on.
Do While Len(DirName) > 0
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
'List2.AddItem path & DirName ' Uncomment to list
End If ' directories.
sysFileERRCont:
End If
DirName = Dir() ' Get next subdirectory.
Loop
' Search through this directory and sum file sizes.
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly Or vbArchive)
'Sheet1.Range("C1").Value2 = path & "\" & FileName
While Len(FileName) <> 0
FindFiles = path & "\" & FileName
FileCount = FileCount + 1
' Load List box
' Sheet1.Range("A1").Value2 = path & FileName & vbTab & _
FileDateTime(path & FileName) ' Include Modified Date
FileName = Dir() ' Get next file.
Wend
' If there are sub-directories..
If nDir > 0 Then
' Recursively walk into them
For i = 0 To nDir - 1
FindFiles = path & "\" & FileName
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont ' Known issue with pagefile.sys
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
Resume AbortFunction
End If
End Function
Sub Find_Files()
Dim SearchPath As String, FindStr As String, SearchPath1 As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Dim Filenames As String, Filenames1 As String
Dim r As Range
'Screen.MousePointer = vbHourglass
'List2.Clear
For Each cell In Range("SS")
SearchPath = Sheet3.Range("B2").Value2
SearchPath1 = Sheet3.Range("B3").Value2
FindStr = Cells(cell.Row, "H").Value
Filenames = FindFiles(SearchPath, FindStr)
Filenames1 = FindFiles(SearchPath1, FindStr)
'Sheet1.Range("B1").Value2 = NumFiles & " Files found in " & NumDirs + 1 & _
" Directories"
Cells(cell.Row, "F").Value = Filenames
Cells(cell.Row, "G").Value = Filenames1
'Format(FileSize, "#,###,###,##0") & " Bytes"
'Screen.MousePointer = vbDefault
Next cell
End Sub
Any thoughts will be highly appreciated.
I realize this question is very old, but it is unanswered. Here is a quick method for finding multiple files and their paths. VBA's DIR function isn't really very handy, but CMD's DIR function is well optimized and has a plethora of command line switches to make it return only files (or even just folders) that match your criteria. The trick is to call DIRfrom a WScript shell so that the output can be parsed by VBA.
For example, this snippet of code will find every file on your system that starts with config.
Dim oShell As Object 'New WshShell if you want early binding
Dim cmd As Object 'WshExec if you want early binding
Dim x As Integer
Const WshRunning = 0
Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec("cmd /c ""Dir c:\config* /a:-d /b /d /s""")
Do While cmd.Status = WshRunning
DoEvents
Loop
Debug.Print cmd.StdOut.ReadAll
Set oShell = Nothing
Set cmd = Nothing