VBA rename files in folder keeping the right order - excel

I've found this code that renames all the files into a specific folder.
Const FolderLoc = "C:\Users\chf000\Desktop\AAA\"
Dim x As Long
x = 1
Dim s As String
s = Dir(FolderLoc & "*.*")
Do While s <> ""
Name FolderLoc & s As FolderLoc & "ANIMATIC-" & x & ".png"
s = Dir()
x = x + 1
Loop
It works, but I've got an issue during the renaming. Basically, I've got a png's sequence into the folder, like this: SHOT001_00.png and SHOT001_01.png and so one.
the sequence has more than 100 frames.
the script changes the name from SHOT001_00.png to ANIMATIC-0.png and so one.
When I run the script, the files are renamed in the wrong order.
For example, the file named ANIMATIC-12.png contains the image that belongs to frame 101.
I guess is a problem of how the script sort the files in the folder, is sorting in a sort of alphabetical order, rather than numerical order.
Does anyone know how can I edit the script in order to rename and keep the correct order?
Thanks

I think you should first put all the names in an array and then rename them from that list.
I use this code to get the file list into an array:
Private Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function

Related

How to only open specific excel files by comparing file names?

I am currently working on a project that requires me to compile data from hundreds of spreadsheets in a given directory. My problem is I'm not sure how to handle different sub-revisions of files. For example the files are named:
File Name R1a.xlsx
File Name R1b.xlsx
File Name R1c.xlsx
File Name R2a.xlsx
File Name R2b.xlsx
For the above files I would only need to read from 1c and 2b. Is there a good way of determining which files need read, or could someone at least point me in a direction that I could look into? My initial thoughts were to loop through the characters in the file names and check for the largest letter that follows a number, but that seems like it would be incredibly tricky to code properly.
Thanks in advance!
There are a number of ways to approach this problem. If your filename domain is truly fixed as R{num}{prio}.xlsx, then note that the filenames constitute valid Excel cell addresses when {prio}.xlsx is stripped away. The resultant cell addresses from your example are R1 and R2. You can now use the R column of the current spreadsheet as a sparse vector to store the highest priority observed per cell (aka file). When all filenames have been examined and their highest priorities stored, it's now a simple matter of traversing the R column to pick up the files selected for processing.
Here's code that handles the aforementioned filename domain....
Sub ProcessFilesBasedOnFnamePriority()
Dim filenames, fname As Variant
Dim maxRowNum, nRowNum, i As Long
Dim strFilePrefix, strCellPrio As String
maxRowNum = 1
filenames = listfiles("c:\temp\lots_of_files")
' make an assumption that all filenames begin with the same
' single-char prefix character.
strFilePrefix = Left(filenames(1), 1)
For Each fname In filenames
Dim dotpos, suffixLen As Integer
Dim strCellAddr, strFnamePrio
dotpos = InStr(1, fname, ".")
suffixLen = Len(Mid(fname, dotpos))
' assume priority is specified by a single char in fname
strFnamePrio = LCase(Mid(fname, dotpos - 1, 1))
strCellAddr = Left(fname, Len(fname) - (suffixLen + 1)) ' "+1" to account for priority char
strCellPrio = Range(strCellAddr)
If (Trim(strCellPrio) = "") Then
Range(strCellAddr) = strFnamePrio ' store first prio occurrence
Else
' assume filename prio characters (e.g., [a-z]) sort lexicographically
If strFnamePrio > strCellPrio Then
Range(strCellAddr) = strFnamePrio
End If
End If
nRowNum = CLng(Mid(strCellAddr, 2))
If nRowNum > maxRowNum Then
maxRowNum = nRowNum
End If
Next
For i = 1 To maxRowNum
strCellPrio = Trim(Range(strFilePrefix & CStr(i)))
If strCellPrio <> "" Then
fname = strFilePrefix & CStr(i) & strCellPrio & ".xlsx"
Debug.Print fname ' <-- do analysis on fname
End If
Next i
End Sub
The code for listfiles is here. Note that this solution will not handle stray files that don't follow the assumed naming pattern. You'll need to add checks to weed them out.
You can store your list of partial file names you need to match in an array. Then loop through the partial names in the array and foreach partial name, loop through the directory to look for a match. VBA provides the InStr function to that you can use to test if a file name contains the partial name from your array.
In pseudocode:
myArray = [ 1c, 2b]
ForEach partialName in myArray
ForEach file in myDirectory
If InStr(fileName, partialName) Then
// Do something interesting
End If
Next file
Next partialName
Use a excel sheet or tabular format to express the file desired.
The excel sheet only needs two columns, A for the filename without the sub-revision, and column B for the desired sub-revision.
Compile and compose this information and then your vba implementation use the excel worksheet/tabular format to iterate and read "only" those files.
Use whatever language to compose the tabular format (in my case, python is preferred) and try to use any thing you can "to determine the sub-revision".
This allows you to debug the results more easily and use whatever language to compile a worksheet formatted or tabular delimited file.
This works because .GetFolder returns a sorted list.
Option Explicit
Sub FilesSelecter()
Dim fs As Object
Dim TargetPath As String
Dim DirList As Object
Dim File As Object
Dim BaseName As String
Dim RootFileName As String
Dim SaveRootFileName As String
Dim SaveBaseName As String
Set fs = CreateObject("Scripting.FileSystemObject")
TargetPath = "C:\Users\BeastMstr\Documents\TestFiles"
Set DirList = fs.Getfolder(TargetPath)
SaveRootFileName = ""
For Each File In DirList.Files
BaseName = fs.getbasename(File)
RootFileName = Left(BaseName, Len(BaseName) - 1)
If SaveRootFileName = RootFileName Or SaveRootFileName = "" Then
SaveRootFileName = RootFileName
SaveBaseName = BaseName
Else
'
'Do Somethingwith SaveBaseName
'
Debug.Print SaveBaseName
SaveRootFileName = RootFileName
SaveBaseName = BaseName
End If
Next
'
' Do something with the last file
'
Debug.Print SaveBaseName
End Sub

how to read a text using condition if

I have an issue and I need your help. here is the problem. I have inside a folder some excel files that I have to open automatically in order to make some operations. Those files have the same name except the number of the files like this:
Folder name : Extraction_Files
Files name : - "System_Extraction_Supplier_1"
- "System_Extraction_Supplier_2"
- "System_Extraction_Supplier_3"
The number of files can change so i used a loop Do While to count the number of files, then the plan is to use a loop for I =1 to ( number of files) to open all of theme.
please read my code. I know that i used a wrong way to read file name using a loop for but I share it because I don't have an other idea.
Here is my code :
Sub OpenFiles ()
Dim MainPath as String
Dim CommonPath as String
Dim Count As Integer
Dim i As Integer
' the main path is " C:\Desktop\Extraction_Files\System_Extraction_Supplier_i"
'with i = 1 to Count ( file number )
CommonPath = "C:\Desktop\Extraction_Files\System_Extraction_Supplier_*"
'counting automatically the file number
Filename = Dir ( CommonPath )
Do While Filename <> ""
Count = Count + 1
Filename = Dir ()
Loop
'the issue is below because this code generate a MsgBox showing a MainPath with the index i like this
'"C:\Desktop\Extraction_Files\System_Extraction_Supplier_i"
' so vba can not find the files
For i = 1 To count
MainPath = "C:\Desktop\Extraction_Files\System_Extraction_Supplier_" & "i"
MsgBox MainPath &
Workbooks.Open MainPath
Next
End Sub
what is the best approach to this?
Why not count as you open them. You're already identifying them so why not open each file as you go:
Sub OpenFiles()
Dim Filename As String
Dim CommonPath As String
Dim Count As Integer
CommonPath = "C:\Desktop\Extraction_Files\"
Filename = Dir(CommonPath & "System_Extraction_Supplier_*")
Do While Filename <> ""
MsgBox Filename
Workbooks.Open CommonPath & Filename
Count = Count + 1
Filename = Dir()
Loop
End Sub
PS. It might be worth adding .xl* or similar to the end of your search pattern to prevent Excel trying to open files that aren't Excel files:
Filename = Dir(CommonPath & "System_Extraction_Supplier_*.xl*")
If you want to open all folders, in a specific folder, which start with "NewFile_", one loop only is needed:
Sub OpenFolders()
Dim path As String: path = ""C:\Desktop\Extraction_Files\""
Dim fileStart As String: fileStart = "System_Extraction_Supplier_"
Dim Fso As Object
Dim objFolder As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = Fso.GetFolder(path)
For Each objSubFolder In objFolder.subfolders
If InStr(1, objSubFolder.Name, fileStart) Then
Shell "explorer.exe " & objSubFolder, vbNormalFocus
Debug.Print objSubFolder.Name
End If
Next objSubFolder
End Sub
Folders in vba are opened with the Shell "explorer.exe " command. The code opens every folder in "C:\yourFile\", which contains NewFile_ in the name. This check is done with If InStr(1, objSubFolder.Name, fileStart) Then.

Loop to check file existence without DIR function

I need to make a loop that will save the edited files in a folder in numerical order, but if I run the macro again it needs to keep from the last number:
wb.SaveAs "C:\User\Desktop\Data\" & i & ".dat"
i = i + 1
Here the code saves the files in order (1,2,3). And if I run the macro again it needs to save (4,5,6).
I tried to use this loop above to save the function:
Do While Dir("C:\User\Desktop\Data\" & i & ".dat") = i
i = i + 1
Loop
But apparently, I can't use the DIR function, because I'm already using it at the end of the loop to get the next file, and the loop breaks.
'Get next file name
MyFile = Dir
So, is there's any way to do this? I'm trying to make a function that would check and return true or false to whether a file with that number already exists, but could not make it work. Thanks for the help.
You could get the largest number in the directory, and keep going from there?
This code presumes that all the files are named as such: [numericalfilename].[extension] for example "143.dat". This code will not work if there are alpha characters in the file-name (apart from extension)
Once you have defined Path and Extension variables, you can call the Function NextNumber which will give you [MaxNumber_In_Directory] + 1
From here you can perform your "save loop", by setting i = NextNumber(Path, "*." & Ext)
Sub test()
Dim Path As String
Dim Ext As String
Dim i as Long
' ***** REPLACE VARIABLES ******
Path = "C:\New\New Folder"
Ext = "dat"
' ******************************
i = NextNumber("C:\New\New Folder", "*." & Ext)
' ********************************
' **** PERFORM SAVE CODE HERE ****
' ********************************
'I am not 100% sure of your save loop, you'll need to modify this
wb.SaveAs "C:\User\Desktop\Data\" & i & ".dat"
i = i + 1
End Sub
Public Function NextNumber(strPath As String, strExt As String) As Long
Dim vArray(500)
Dim i As Long
Dim length As Long
ChDir strPath
strExtension = Dir(strExt)
'Perform Loop
Do While strExtension <> ""
length = Len(strExtension) - (Len(strExt) - 2) - 1
vArray(i) = CLng(Mid(strExtension, 1, length))
i = i + 1
strExtension = Dir
Loop
NextNumber = WorksheetFunction.Max(vArray) + 1
End Function

compare two values and generate a percentage (excel)

I am currently trying to create a spreadsheet which keeps track of how many files have been quality checked against those that haven't and then displays the amount left to be checked as a percentage.
Currently on open the spreadsheet pulls the details from a checked folder and a work to be checked folder as follows:-
Private Sub pdf_loading()
Range("M5").Clear
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\path to folder\"
' looks in spercific folder
path = FolderPath & "*.pdf"
' for file type this time it is pdf files, though if you change this is could be word files, or psd's
Filename = Dir(path)
Do While Filename <> ""
' checks for filename <less than or >greater than "filename" as "" is empty does not look for spercific file
count = count + 1
' counts amount of pdf files, add 1 to the last known number
Filename = Dir()
' contiunes count until it reaches the end of the directory
Loop
Range("M5").Value = count
' puts final count value in cell
For Each Cell In [M:M]
If Cell.Value = "0" Then
Cell.ClearContents
ElseIf Range("M5").Value >= 1 Then
End If
Next Cell
End Sub
Then for the checked folder:-
Private Sub checked_loading()
Range("M6").Clear
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\path to folder\"
path = FolderPath & "*.pdf"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range("M6").Value = count
For Each Cell In [M:M]
If Cell.Value = "0" Then
Cell.ClearContents
ElseIf Range("M5").Value >= 1 Then
End If
Next Cell
End Sub
This works fine, though currently the formula I have tried to generate the percentage is as follows:-
=IF(M5=M6,"50%",IF(M5=0,"100%",IF(M6=0,"0%",SUM(M5*M6/100*1))))
This brings back incorrect results like 144.00% when the files to be check result is 9 and the files checked result is 16.
I would prefer to have the percentage calculation to be in vba so that end users could not accidentally delete the underlying formula.
Any help on this issue or if there is a more efficient code structure would be most appreciate.
Not to worry I have found a solution which works a treat. The above code now looks like this for the work to be checked:-
Private Sub pdf_loading()
Range("K5:L6").ClearContents
Range("M5").ClearContents
' Clear cell contents on open
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\filepath\folder\"
' looks in spercific folder
path = FolderPath & "*.pdf"
' for file type this time it is pdf files, though if you change this is could be word files, or psd's
Filename = Dir(path)
Do While Filename <> ""
' checks for filename <less than or >greater than "filename" as "" is empty does not look for spercific file
count = count + 1
' counts amount of pdf files, add 1 to the last known number
Filename = Dir()
' contiunes count until it reaches the end of the directory
Loop
Range("M5").Value = count
' puts final count value in cell
End Sub
and the work checked folder is now like this:-
Private Sub checked_loading()
Range("M6").ClearContents
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\filepath\folder\"
path = FolderPath & "*.pdf"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range("M6").Value = count
Range("N5").Formula = "=Sum(M5,M6)"
Range("K5").Formula = "=SUM(M6/N5*1)"
' adds formulas to selected cells to give percentage
End Sub

How to create a file with contents based on files in a directory

I have an existing xls file which creates a CONTENTS file based on the files in a directory. For example, if a directory contains file.pdf and file.txt, it will create a file with contents
file.pdf
file.txt
with each file separated by a line break.
What I would like to do is that I want the contents to contain
file.pdf bundle:ORIGINAL
file.txt bundle:TEXT
file.pdf and bundle:ORIGINAL is separated by a tab character. The directory will contain these 2 filetypes, 1 pdf and 1 text file. So basically, what I want is that for every pdf file, it should be followed by bundle:ORIGINAL text while if its a text file, it should be followed by bundle:TEXT.
The original code is below:
For i = 2 To lRows
If Trim(Cells(i, 1).Value) = "" Then Exit For
' create the CONTENTS file
FileList = GetFileList(oDirectory & "\" & Trim(Cells(i, lCols).Value) & "\")
cFileNum = FreeFile
ContentsPath = oDirectory & "\" & Trim(Cells(i, lCols).Value) & "\" & "contents"
Open ContentsPath For Output As #cFileNum
For k = 1 To UBound(FileList)
If (FileList(k) <> "contents" And FileList(k) <> "dublin_core.xml") Then
Print #cFileNum, FileList(k)
End If
Next k
Close #cFileNum
EDIT
This is the Function GetFileList
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Please note that I am obviously not the author of this code, I just downloaded this excel file (the site no longer exists) a long time ago and I just need to tweak this for my own use.
Thanks in advance.
Something like this should do it:
'...
If (FileList(k) <> "contents" And FileList(k) <> "dublin_core.xml") Then
Print #cFileNum, FileList(k) & vbTab & GetType(Cstr(FileList(k)))
End If
'...
Function:
Function GetType(fName as string)
Dim rv As String
Select Case Right(Ucase(fName),3)
Case "TXT": rv = "bundle:TEXT"
Case "PDF": rv = "bundle:ORIGINAL"
End Select
GetType = rv
End Function

Resources