This question already has answers here:
File extension validation
(2 answers)
Closed 1 year ago.
i need to store the extension from files in a variable in VBA,
What i've done for now is
file= Hello.pdf
extension = split(file,".")(1)
But sometimes my file could be like file = 1.Filename.pdf and so my extension variable is not working anymore...
could someone help me to find a solution to always get the extension from any file name even if they are multiples "." in it.
i had an idea it waas to read from right to left and get the string when it read a "." but i'm new in vba and don't know where to look to start it....
Try,
Dim vFn As Variant
file = "Hello.pdf"
vFn = Split(file, ".")
extension = vFn(UBound(vFn))
Try this
Sub Get_Extension()
Dim fso As Object, sFile As String
Set fso = CreateObject("Scripting.FileSystemObject")
sFile = "Hello.pdf"
Debug.Print Right(sFile, Len(sFile) - InStrRev(sFile, "."))
Debug.Print fso.GetExtensionName(sFile)
Debug.Print Split(sFile, ".")(UBound(Split(sFile, ".")))
End Sub
To get the file name you can use that
Sub Get_Filename()
Dim v, fso As Object, sFile As String
Set fso = CreateObject("Scripting.FileSystemObject")
sFile = "1.Hello.pdf"
v = Split(sFile, ".")
ReDim Preserve v(0 To UBound(v) - 1)
Debug.Print Join(v, ".")
Debug.Print fso.GetBaseName(sFile)
Debug.Print Left(sFile, (InStrRev(sFile, ".", -1, vbTextCompare) - 1))
Debug.Print Left(sFile, InStrRev(sFile, ".") - 1)
End Sub
Related
I was wondering whether there is a (built in/simple) option to reference/connect/link to a workbook that has a variable name?
My xy-problem is, I have workbook b v45.xlsm and wish to export data to workbook a v34.xlsm where the version numbers vary. So I was wondering if there is a sub-ID for each workbook, to which excel can refence independent of the name, automatically picking the most recent version in that folder.
Of course the simple solution is to pick the most recently modified excel file in the folderpath containing the string "a v", assuming an identical folderpath, but I was curious if there was a more convential/integrated option for this.
Kind regards.
(For future people looking at this issue, here is my manual solution:)
Sub find_planner_name()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim string_object(0 To 2) As String 'saving the filenames as strings
Dim count As Integer 'counting nr of files encountered
Dim save_version_number(0 To 1) As Long
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
'Cells(i + 1, 1) = objFile.name
count = count + 1
ReDim version_number(0 To count) As Long
string_object(0) = ""
string_object(1) = ""
string_object(2) = ""
string_object(0) = objFile.name
If Right(string_object(0), 5) = ".xlsm" Or Right(string_object(0), 5) = ".xlsb" Then
If Left(string_object(0), 10) = " planner v" Or Left(string_object(0), 10) = " planner v" Then
string_object(1) = Right(string_object(0), Len(string_object(0)) - 10)
MsgBox (string_object(1))
Do While IsNumeric(Left(string_object(1), 1)) = True
If IsNumeric(Left(string_object(1), 1)) = True Then
string_object(2) = string_object(2) & Left(string_object(1), 1)
string_object(1) = Right(string_object(1), Len(string_object(1)) - 1)
End If
Loop
If version_number(count) < string_object(2) And string_object(2) > 0 Then
version_number(count) = string_object(2)
MsgBox (version_number(count))
save_version_number(0) = version_number(count)
save_version_number(1) = count
End If
End If
End If
i = i + 1
Next objFile
count = save_version_number(1) 'rewrite maxima back
version_number(count) = save_version_number(0) 'rewrite maxima back
'MsgBox ("done " & version_number(count))
Dim myMax As Long
Dim count_results As Long
For count_results = LBound(version_number, 1) To UBound(version_number, 1)
If version_number(count_results) > myMax Then
myMax = version_number(count_results)
Findmax = count_results
'MsgBox (version_number(count_results))
End If
'MsgBox (version_number(count_results) & " and count_results = " & count_results)
Next count_results
'the name of the planner =
name_planner = " planner v" & version_number(Findmax) & ".xlsm"
' check if xlsm or xlsb
'MsgBox (name_planner)
If Dir(ThisWorkbook.Path & "\" & name_planner) <> "" Then
MsgBox ("File exists. and name is " & name_planner)
Else
name_planner = " planner v" & version_number(Findmax) & ".xlsb"
End If
End Sub
It should be more reliable to parse filenames looking at the version numbers rather than looking at the most recently modified file. Loop through all of them checking the filename with something like:
strFile = Dir(DirectoryPath)
Do while strFile <> ""
'Code here to parse strFile for intNewVersionNumber
if intNewVersionNumber > intVersionNumber then intVersionNumber = intNewVersionNumber
strFile = Dir
Loop
strFile = 'Code here to reconstruct filename from intVersionNumber
From your question, I think this might actually be necessary, even though there may be a couple of ways of adding/checking metadata on Excel files.
When you say the workbook name changes, it is literally the exact same file being renamed through Windows Explorer, or do you have multiple versions in the same folder created when you use Save As...? The issue of "automatically picking the most recent version" suggests that there are new versions being created in the same folder. If so, it means that you're actually changing which workbook you're linking to, so any kind of link to a file isn't going to work anyway. Also, even if you put in a sub-ID, each version will still have that same sub-ID. While this can still identify the files that are different versions of the same file, you still have to loop through all of those files looking for the latest version. A sub-ID would help if the filename is changing entirely, but doesn't remove the need to search through the different versions. So, if you can keep a consistent filename with only the version number changing, you'll be able to implement the simplest solution possible.
I have a tool that copies all files from one folder into 10 seperate folders (all stored on different servers).
Sometimes when running this tool, I will get a permission denied error - which I presume comes down to a user being in one of the files that the program tries to overwrite.
Is there a way to confirm where the error occurs, and on top of that.. is there any way to create a report which shows which files were unsuccessful, but continue running after hitting the error?
Hope this makes sense, it is a generic FSO loop (think it was ron de bruin example)
Can you help? Error handling is definitely not my VBA forte!
I have the variables set before this with the filepaths and a seperate macro for each folder that gets copied - here is the code below
Handling the error is more important for me right now as it would let me pinpoint the issue
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
If Right(ToPath2, 1) = "\" Then
ToPath = Left(ToPath2, Len(ToPath) - 1)
End If
If Right(ToPath3, 1) = "\" Then
ToPath = Left(ToPath3, Len(ToPath) - 1)
End If
If Right(ToPath4, 1) = "\" Then
ToPath = Left(ToPath4, Len(ToPath) - 1)
End If
If Right(ToPath5, 1) = "\" Then
ToPath = Left(ToPath5, Len(ToPath) - 1)
End If
If Right(ToPath6, 1) = "\" Then
ToPath = Left(ToPath6, Len(ToPath) - 1)
End If
If Right(ToPath7, 1) = "\" Then
ToPath = Left(ToPath7, Len(ToPath) - 1)
End If
If Right(ToPath8, 1) = "\" Then
ToPath = Left(ToPath8, Len(ToPath) - 1)
End If
If Right(ToPath9, 1) = "\" Then
ToPath = Left(ToPath9, Len(ToPath) - 1)
End If
If Right(ToPath10, 1) = "\" Then
ToPath = Left(ToPath10, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
FSO.CopyFolder Source:=FromPath, Destination:=ToPath2
FSO.CopyFolder Source:=FromPath, Destination:=ToPath3
FSO.CopyFolder Source:=FromPath, Destination:=ToPath4
FSO.CopyFolder Source:=FromPath, Destination:=ToPath5
FSO.CopyFolder Source:=FromPath, Destination:=ToPath6
FSO.CopyFolder Source:=FromPath, Destination:=ToPath7
FSO.CopyFolder Source:=FromPath, Destination:=ToPath8
FSO.CopyFolder Source:=FromPath, Destination:=ToPath9
FSO.CopyFolder Source:=FromPath, Destination:=ToPath10
Let's see if this helps out at all. The idea is to use your FSO to open the destination folder, and attempt to delete each file & subdirectory in the folder. This relies on the helper functions DeleteFile and DeleteFolder.
Module declarations: Important!
Option Explicit
Dim errors As Collection
Dim file As Object 'Scripting.File
Dim fldr As Object 'Scripting.Folder
This is the main procedure, note that you MUST declare all of your variables because of the Option Explicit at the module level.
Sub CopyFolderWithErrorHandling()
Dim FSO As Object 'Scripting.FileSystemObject
Dim paths As Variant
Dim path As Variant
Dim FromPath As String
Dim i As Long
Dim ToPath1$, ToPath2$, ToPath3$, ToPath4$, ToPath5$, ToPath6$, ToPath7$, ToPath8$, ToPath9$, ToPath10$
'!!!### IMPORTANT ###!!!
' Assign all of your "ToPath" variables here:
ToPath1 = "c:\some\path"
'Etc.
Set FSO = CreateObject("scripting.filesystemobject")
Set errors = New Collection
FromPath = "C:\Debug\" '## Modify as needed
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
'## Create an array of destination paths for concise coding
paths = Array(ToPath1, ToPath2, ToPath3, ToPath4, ToPath5, ToPath6, ToPath7, ToPath8, ToPath9, ToPath10)
'## Ensure each path is well-formed:
For i = 0 To UBound(paths)
path = paths(i)
If Right(path, 1) = "\" Then
path = Left(path, Len(path) - 1)
End If
paths(i) = path
Next
'## Attempt to delete the destination paths and identify any file locks
For Each path In paths
'# This funcitno will attempt to delete each file & subdirectory in the folder path
Call DeleteFolder(FSO, path)
Next
'## If there are no errors, then do the copy:
If errors.Count = 0 Then
For Each path In paths
FSO.CopyFolder FromPath, path
Next
Else:
'# inform you of errors, you should modify to print a text file...
Dim str$
For Each e In errors
str = str & e & vbNewLine
Next
'## Create an error log on your desktop
FSO.CreateTextFile(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\errors.txt").Write str
End If
Set errors = Nothing
End Sub
Helper functions:
The DeleteFolder procedure calls on DeleteFile for each file at its top level, and then calls itself recursively for each subdirectory in the specified folder path, if any.
The DeleteFile procedure logs each error to the errors collection, which we then use to write to a text file on your Desktop.
Sub DeleteFolder(FSO As Object, path As Variant)
'Check each file in the folder
For Each file In FSO.GetFolder(path).Files
Call DeleteFile(FSO, file)
Next
'Check each subdirectory
For Each fldr In FSO.GetFolder(path).SubFolders
Call DeleteFolder(FSO, fldr.path)
Next
End Sub
Sub DeleteFile(FSO As Object, file)
On Error Resume Next
Kill file.path
If Err.Number <> 0 Then
errors.Add file.path
End If
End Sub
Observations
The error log may contain some duplicates, or near-duplicates, as a lock file may be created, e.g. below. These are usually denoted with a tilde character, but since that is legal in a file name, I do not make any attempt to isolate or ignore "duplicates":
c:\my files\excel_file1.xlsx
c:\my files\~excel_file1.xlsx
Certain file types may not raise an error that can be trapped in the above code (.txt for example I think will not error if open in Notepad, etc.). In these cases, the above procedures I think will successfully delete the file, but now you have the risk that the user may save the old version over your newly copied version. I don't know how to prevent this from happening; your problem really is an architecture and replication one, and that is not well-suited to be handled by VBA from Excel...
As we know, we use Find() method to find whether a string or any Microsoft Excel data type exists in an excel.
(Usually we do it on set of data)
I want to know if any such method available when we loop through folder(of files) using Dir function.
Situation:
I have an excel - 'FileNames.xlsx' in which 'Sheet1' has names of files having extensions .pdf/.jpg/.jpeg/.xls/.xlsx/.png./.txt/.docx/ .rtf in column A.
I have a folder named 'Folder' which has most(or all) of the files from 'FileNames.xlsx'.
I have to check whether all the file-names mentioned in the 'FileNames.xlsx' exist in 'Folder'.
For this I have written the below VBScript(.vbs):
strMessage =Inputbox("Enter No. of Files in Folder","Input Required")
set xlinput = createobject("excel.application")
set wb123 =xlinput.workbooks.Open("E:\FileNames.xlsx")
set sh1 =wb123.worksheets("Sheet1")
For i = 2 to strMessage +1
namei = sh1.cells(i,1).value
yesi = "E:\Folder"+ namei +
If namei <> yesi Then
sh1.cells(i,1).Interior.Color = vbRed
Else
End If
Next
msgbox "Success"
xlinput.quit
As I wasn't able to get the required Output I tried it recording a small Excel VBA Macro. (Changed FileNames.xlsx to FileNames.xlsm)
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2A:" & lastRow)
MyFile = Dir(MyFolder & "\*.xlsx")
'Here I actually need to pass all file extensions to Dir
Do While MyFile <> ""
If filename = MyFile Then
'Do Nothing
Else
filename.Interior.Color = vbRed
MyFile = Dir
Next
End Sub
The above is a failed attempt.
I thought of trying it with method similar to Find()
Sub LoopThroughFiles()
Dim lastRow As Long
'Dim LastFile As Long
'Is there need of it (LastFile variable)? I kept this variable
'to save (prior known) count of files in folder.
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
'LastFile = 'Pass count of Files in folder to this variable.
Dim fileName As Range
For Each fileName In Worksheets("Sheet1").Range("A2:A" & lastRow)
Dim rngFnder As Range
On Error Resume Next
'Error at below line.
Set rngFnder = Dir("E:\Folder\").Find(filename)
'This line gives me error 'Invalid Qualifier'
'I am trying to use method similar to Find()
If rngFnder Is Nothing Then
filename.Interior.Color = vbRed
End If
Next
End Sub
But, I couldn't achieve the result. Can anyone tell me is there any such function available to 'Find' whether all filenames in an excel exist in a folder after looping through folder using Dir?
As per my knowledge, Dir function works with only one file extension at a time.
Is it possible to use Dir function for multiple file extensions at a time?
Expected Output:
Assume I have 8 filenames in 'FileNames(.xlsx/.xlsm)'. Out of which Arabella.pdf and Clover.png are not found in 'Folder', Then I want to color cells for these filenames in red background in excel as in below image.
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2:A" & lastRow)
MyFile = MyFolder & "\" & filename
If Not FileExists(MyFile) Then
filename.Interior.Color = vbRed
End If
Next
End Sub
Public Function FileExists(strFullpathName As String) As Boolean
If Dir(strFullpathName) <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function
You can output a list of the files that are contained in the folder. I found a really helpful tutorial on that here: http://software-solutions-online.com/2014/03/05/list-files-and-folders-in-a-directory/#Jump1
If you then loop through both the original and the output lists and look for a match. Easiest is to first colour them all red, and un-colour the matches. Else you would need an additional if-statement that states: When you reach the last element in the original list, and no match has been found, then colour red.
Edit: For continuity's sake I copied the code bits of the link I mentioned above:
Getting all file names form within 1 folder:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("D:StuffFreelancesWebsiteBlogArraysPics")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
This code uses Dir to get sub-dirs. Each sub-dir needs to have its xls files processed. After it finishes processing the first batch of xls, I get invalid procedure call or argument. I am guessing when I pass dirLook to the function it creates a copy? Please assist. I need to move on to the next sub-dir.
dirLook = dir(strDir, vbDirectory)
Do While dirLook <> ""
If dirLook <> "." And dirLook <> ".." Then
If (GetAttr(strDir & adir) And vbDirectory) = vbDirectory Then
'Perform action on folder here
loopXls (dirLook)
Debug.Print dirLook
End If
End If
dirLook = dir
Loop
loopXls:
Function loopXls(dirStr As String)
Dim count As Integer
Dim strFilename As String
Dim strPath As String
Dim wbkTemp As Workbook
strPath = "C:\Users\pmevi\Documents\L7\L7_Master_Book\Input\" & dirStr & "\"
strFilename = dir(strPath & "*.xls")
Do While Len(strFilename) > 0
Set wbkTemp = Workbooks.Open(strPath & strFilename)
'
' do your code with the workbook
'
' save and close it
wbkTemp.Close True
count = count + 1
strFilename = dir
Loop
Debug.Print (count)
End Function
EDIT2
I am attemping to load each dir into an array, but for some reason when I loop through array I only see 3 folders instead of 5.
Dim dirs(5) As String
Dim i As Integer
Dim endNum As Integer
endNum = 4
dirLook = dir(strDir, vbDirectory)
For i = 0 To endNum
dirs(i) = dirLook
dirLook = dir
Next i
For i = 0 To endNum
Debug.Print (dirs(i))
Next i
output:
3-10-14
3-11-14
3-12-14
expected:
3-10-14
3-11-14
3-12-14
3-13-14
3-14-14
Edit3
Found issue to array. 2 indexes are used for "." and ".."
It's not exactly clear from the code, but if the code above is in the loopXls method, making this a recursive function then the problem is that you cannot use the Dir function recursively, as stated here, towards the bottom.
The answer here include shows an example class for recursing with the Dir function.
I wish to return the file size of some files in the same folder or in a different one with VBA in Excel 2010.
There is a very nice and simple VBA function, which was not mentioned so far, FileLen:
FileLen("C:\Temp\test file.xls")
It returns the size of the file in bytes.
In combination with looping through files in a directory it's possible to achieve what you originally wanted (get sizes of files in a folder).
Here how to use it in Excel Cell:
=GetDirOrFileSize("C:\Users\xxx\Playground\","filename.xxx")
If you have a german Windows than:
=GetDirOrFileSize("C:\Users\xxx\Playground\";"filename.xxx")
Here is the function for the VBA modul: (Just enable the Developer tools, and copy and paste this into a new modul)
Function GetDirOrFileSize(strFolder As String, Optional strFile As Variant) As Long
'Call Sequence: GetDirOrFileSize("drive\path"[,"filename.ext"])
Dim lngFSize As Long, lngDSize As Long
Dim oFO As Object
Dim oFD As Object
Dim OFS As Object
lngFSize = 0
Set OFS = CreateObject("Scripting.FileSystemObject")
If strFolder = "" Then strFolder = ActiveWorkbook.path
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
'Thanks to Jean-Francois Corbett, you can use also OFS.BuildPath(strFolder, strFile)
If OFS.FolderExists(strFolder) Then
If Not IsMissing(strFile) Then
If OFS.FileExists(strFolder & strFile) Then
Set oFO = OFS.Getfile(strFolder & strFile)
GetDirOrFileSize = oFO.Size
End If
Else
Set oFD = OFS.GetFolder(strFolder)
GetDirOrFileSize = oFD.Size
End If
End If
End Function '*** GetDirOrFileSize ***