I am wondering if anyone can help me edit this VBA script so that it not only moves the files (this part is complete by the way), but it also appends a 0 to the front of the filename (this part has not been started.
So, if the original filename is 123456789.tif, then the resultant will be 0123456789.tif.
Thank you!
Sub MoveIfFilelength()
'This script moves files from a source directory to a final directory based on the number of characters in the filename (e.g., 14, as below)
Dim srcDir As String
Dim dstDir As String
Dim f As String
srcDir = "S:\\" 'Input source directory
dstDir = "S:\\" 'Input destination directory
f = Dir(srcDir)
Do While f <> ""
If Len(f) = 13 Then Name srcDir & "\" & f As dstDir & "\" & f 'Input filename length
f = Dir()
Loop
End Sub
Name .. As is the move operation which is semantically a rename already, so specify the new name as "\0" & f:
If Len(f) = 13 Then Name srcDir & "\" & f As dstDir & "\0" & f
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 need to do a code in VBA to find a file in a subdirectory.
With the code from 'brettdj' in this link I can find the file if I specify the full directory
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("\\A\B\C\D\")
While (file <> "")
If InStr(file, "701000034955") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
I'm looking for a why to not to have to specify the full directory.
I tried the code in this link, but I get a 'type mistmatch' error message in the last line
Sub Find_Files()
f = "\\A\B\"
ibox = "701000034955"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets("Sheet1").[A1].Resize(UBound(sn) + 1) = Application.Transpose(sn) ' I get an error message in this line
End Sub
Any ideas on why the code above is not working and if there is a better solution to search in subfolders for a file?
your second code differs from the first one in that this latter searches for any file in given folder (and subfolders) whose name is exactly "701000034955" while the former searches for file whose name contains that string
hence I guess you just have to use some wildchars
ibox = "*701000034955*"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & Application.PathSeparator & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets("Sheet1").[A1].Resize(UBound(sn)) = Application.Transpose(sn)
note the resizing is UBound(sn) instead of UBound(sn) + 1 since there's one endingvbCrlf generating an empty entry in the last position of sn
For the bottom one don't forget to fully qualify the file name with its extension and consider using Path separator to concatenate. For example:
Sub Find_Files()
Dim f As String
f = ThisWorkbook.Path
ibox = "701000034955.xlsb"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & Application.PathSeparator & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets("Sheet1").[A1].Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub
I want to create a code which looks for the file in the file directory and tells me if its there given only a fraction of the file name.
I have put this fraction i column I8 of the Macro sheet which is a number "121"
The below code works if i manually put the number 121 instead of i, but when referencing i from the cell it just flags a random excel file in the directory
Dim FilePath3 As String
Dim i As String
FilePath3 = Sheets("Macro").Range("J6")
i = Sheets("Macro").Range("I8")
file = Dir$(FilePath3 & "*i*" & ".*")
If (Len(file) > 0) Then
MsgBox "found " & file
End If
i is inside of your block of text "*i*" , so it isn't the variable i that you defined earlier in the code!
Furthermore, you can use Dir() inside of a loop like this to see if there is multiple results :
Dim FilePath3 As String
Dim i As String
FilePath3 = Sheets("Macro").Range("J6")
i = Sheets("Macro").Range("I8")
file = Dir$(FilePath3 & "*" & i & "*.*")
Do While file <> vbNullString
If (Len(file) > 0) Then
MsgBox "found " & file
End If
file = Dir()
Loop
how do i auto rename multiple files that are being copied with different indexing? i mean the (0), (1), etc... i.e. if i have two files in Folder1 that has a.txt and b.txt, And another two same files inside the Folder2 And copy the a.txt and b.txt from Folder1 to Folder2 then the a.txt will become a(1).txt and the b.txt to b(1).txt. how do i do it in a single instance? what came to my mind is to have many Strings and Integers as many as the files, but i will be dealing thousands of files. This is what i have so far.
Dim ii as Integer = 0
Dim iii as Integer = 0
Sub Copy()
For i = 0 To updatedFiles.Count - 1
Dim fileName As String = Path.GetFileNameWithoutExtension(updatedFiles(i))
Dim filePath As String = Path.GetDirectoryName(updatedFiles(i))
Dim fileExt As String = Path.GetExtension(updatedFiles(i))
Dim newFile As String = filePath & "\" & fileName & "(" & ii & ")" & fileExt
Dim newFile2 As String = filePath & "\" & fileName & "(" & iii & ")" & fileExt
If File.Exists(Path.Combine(dest, updatedFiles(i))) Then
ii += 1
'Copy newFile
ElseIf File.Exists(Path.Combine(dest, newFile)) Then
iii += 1
'Copy newFile2
End If
Next
End Sub
This doesn't do it right, from the situation above, the a.txt becomes a(1).txt but the b.txt becomes b(2).txt. the result should be
a (1).txt
b (1).txt
You will need to have: Imports System.IO
When Copy() is run, all of the files from the source folder will be copied over to the destination folder, and renamed file(1).ext, file(2).ext, etc. if the file already exists in the destination folder:
Dim sourceFolder As String = "C:\Users\Public\Documents\Folder1"
Dim destFolder As String = "C:\Users\Public\Documents\Folder2"
Sub Copy()
Dim allFiles() As String 'Put all files in an array
allFiles = Directory.GetFiles(sourceFolder)
Dim i As Integer = 0 'File counter
Dim fileName As String = "" 'This will be name of file without path
Dim fileNameNoExt As String = "" 'Name of file without extension
Dim fileExt As String = "" 'File Extension
For j As Integer = 0 To allFiles.Count - 1
i = 1 're-initialize i
fileName = allFiles(j).Substring(allFiles(j).LastIndexOf("\") + 1)
fileNameNoExt = allFiles(j).Substring(allFiles(j).LastIndexOf("\"), allFiles(i).LastIndexOf(".") - allFiles(j).LastIndexOf("\"))
fileExt = allFiles(j).Substring(allFiles(j).LastIndexOf(".") + 1)
If File.Exists(destFolder & "\" & fileName) Then
While File.Exists(destFolder & "\" & fileNameNoExt & "(" & i & ")." & fileExt)
i += 1
'when while fails, i will hold the next value for file
End While
File.Copy(allFiles(j), destFolder & "\" & fileNameNoExt & "(" & i & ")." & fileExt)
Else
File.Copy(allFiles(j), destFolder & "\" & fileName)
'if there is no file with the same name, there is a direct copy of the file to the destination folder
End If
Next
End Sub
Easiest way is iterate twice. Once to add something to the name like aTBR.txt, bTBR.txt. TBR(To be renamed). You can put anything.
Second time to change name to what you would like it to be.
Harder way but maybe faster is to start with renaming last object. d.txt to e.txt?? then c.txt to d.txt, b.txt to c.txt
For that option you would need to keep their names in order in some array, or have them in alphabetic order and store their names array when you load app.
Update:
put Dim ii as Integer = 0
Dim iii as Integer = 0
inside for loop
I've developed the following code to save all publisher files in the current directory as an image, however it seems to take a long time to run through. Also, I can't figure out a way to exclude the current file that the macro is running from. Anyone got any ideas?
Sub Looptest()
Dim MyFile As String, Sep As String
Dim objPub As Object
Set objPub = CreateObject("Publisher.Application")
Dim folder As String
folder = CurDir()
If Len(Dir(folder & "\" & "jpg", vbDirectory)) = 0 Then
MkDir (folder & "\" & "jpg")
End If
Sep = Application.PathSeparator
If Sep = "\" Then
' Windows platform search syntax.
MyFile = Dir(CurDir() & Sep & "*.pub")
Else
MyFile = Dir("", MacID("XLS5"))
End If
' Starts the loop, which will continue until there are no more files
' found.
Do While MyFile <> ""
'If MyFile = "macro.pub" Then
'GoTo ContinueLoop
'End If
Dim pubApp As Publisher.Application
Dim pubDoc As Publisher.Document
Dim folder2 As String
folder2 = CurDir() & Sep & MyFile
Set pubApp = New Publisher.Application
pubApp.Open folder2
'pubApp.ActiveWindow.Visible = True
num = folder2
pubApp.ActiveDocument.Pages(1).SaveAsPicture CurDir() & Sep & "jpg" & "\" & MyFile & ".jpg"
pubApp.Quit
MyFile = Dir()
'ContinueLoop:
Loop
End Sub
I've commented out my attempt at skipping the file (called Macro.pub in this instance), as it just seemed to stall and not go anywhere.
Any help would be greatly appreciated!
-Cr1kk0
Assuming your code is correct in all other respects, this might do the trick
If MyFile = ActiveDocument.FullName Then
GoTo ContinueLoop
End If
I'm guessing your check fails because you're comparing a short file name to a full file name. (You could also just hardcode the entire path to macro.pub)