I have a file path (which is a connection path for the worksheet) in the following format:
C:\ExcelFiles\Data\20140522\File1_20140522.csv
I want to extract 20140522.
I tried using responses of How to extract groups of numbers from a string in vba, but they don't seem to work in my case.
please find below
Filename = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
a = Replace(Mid(Filename, InStrRev(Filename, "_") + 1, Len(Filename)), ".csv", "")
Try the following. Folder is selected.
Sub Folder_S()
Dim sFolder As FileDialog
On Error Resume Next
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
Folder_Select sFolder.SelectedItems(1), True
End If
End Sub
Sub Folder_Select(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim strFile As String
Dim FileName As Variant
Dim pathParts() As String
Dim pathPart As String
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
pathParts = Split(SourceFolder.Path, Application.PathSeparator)
pathPart = SourceFolder.Path
For i = 0 To UBound(pathParts)
If pathParts(i) = "20140522" Then
pathPart = pathParts(i - 0)
Exit For
End If
Next i
Row = ActiveCell.Row
With CreateObject("Scripting.Dictionary")
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
.Item(strFile) = Array(FileItem.Name)
Next FileItem
If .Count > 0 Then
For Each FileName In .Items
Cells(Row, 2).Formula = pathPart
Next FileName
End If
End With
End Sub
I found your question by searching a solution how to get a folder path from a file that is inside this folder path. But your question doesn't match exactly what I need. For those who by your question title will find it for the same purpose as I found, below is my function:
Function getFolderPathFromFilePath(filePath As String) As String
Dim lastPathSeparatorPosition As Long
lastPathSeparatorPosition = InStrRev(filePath, Application.PathSeparator)
getFolderPathFromFilePath = Left(filePath, lastPathSeparatorPosition - 1)
End Function
In some solutions for this purpose, I used FSO, but it takes resources, and I think it isn't worthy to create FSO object if you need it only for this simple function.
the accepted answer is not accurate to read the folder name. here is more dynamic code.
use splitter which splits string based on delimeter and makes an array. now read the second last element in array, thats the folder name.
Dim fileName As String
fileName = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
Dim vPathSplitter As Variant
vPathSplitter = Split(fileName, "\")
MsgBox (vPathSplitter(UBound(vPathSplitter) - 1))
The below answer gets your file path from a range, rather than a fixed string. Much more handy if your planning on getting your filename from your sheets, which I imagine you are.
Sub GetFileDate()
Dim filename As String
filename = Sheets("Sheet1").Range("C9").Value 'Or Wherever your file path is
MsgBox Replace(Right(filename, 12), ".csv", "")
End Sub
This assumes the numbers your extracting will ALWAYS be dates in YYYYMMDD format and the file type is always .csv
Related
I am trying to loop through all subfolders. This script works but then only pulls some folders and not others. I need it to pull all files in the folder. I did not create this full script but would like to modify it.
UPDATE:
I tried this alternate solution below and it works.
Sub loopAllSubFolderSelectStartDirectory()
Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
'Set the folder name to a variable
folderName = "C:\Users\dreid_000\Desktop\PhaseII\"
'Set the reference to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
'Another Macro must call LoopAllSubFolders Macro to start
LoopAllSubFolders FSOLibrary.GetFolder(folderName)
End Sub
Sub LoopAllSubFolders(FSOFolder As Object)
Dim FSOSubFolder As Object
Dim FSOFile As Object
Dim soldname As String
Dim sNewName As String
Dim sTempFile() As String
Dim sPath As String
Set Fso = CreateObject("Scripting.FileSystemObject")
'For each subfolder call the macro
For Each FSOSubFolder In FSOFolder.subfolders
LoopAllSubFolders FSOSubFolder
Next
'For each file, print the name
For Each FSOFile In FSOFolder.Files
'Insert the actions to be performed on each file
FSOFile.Name = "PhaseII.xlsx"
'This example will print the full file path to the immediate window
Debug.Print FSOFile.Path
Next
End Sub
Here is a good, generic solution that can meet basically any search folder and its subfolders requirements. It is a function that calls itself recursively and outputs a dictionary object containing the complete results, code commented for clarity:
Public Function SearchDirectory(ByVal arg_sFolderPath As String, _
Optional ByVal arg_sSearch As String = "*", _
Optional ByVal arg_bMatchCase As Boolean = False, _
Optional ByVal arg_bIncludeSubFolders As Boolean = True, _
Optional ByRef arg_hResults As Object) _
As Object
'Purpose of this function is to search a directory (and probably all of its subfolders)
'for files that match an optionally provided search string, and the match may or may
'not be case sensitive. It then collects all of the results in a dictionary object and
'returns that dictionary object as the function output
'
'Parameters:
' arg_sFolderPath: [Required][String] -The folder path of the original directory that will be searched
'
' arg_sSearch: [Optional][String] -A pattern that will be matched against.
' -For example, to find all Excel files you would use "*.xls*"
' -Default value is "*" which will return all files
'
' arg_bMatchCase: [Optional][Boolean] -Specifies whether or not to match arg_sSearch as case sensitive
' -For example, if this is set to True and the arg_sSearch is set to "*.xls*",
' then an Excel file named "EXCELFILE.XLSX" would NOT be found
' -Default value is False which will make matches not case sensitive
'
' arg_bIncludeSubFolders [Optional][Boolean] -Specifies whether or not to search all subfolders recursively
' -Default value is True which will include results in all subfolders
'
' arg_hResults [Optional][Dictionary Object] -An existing dictionary object to hold the results in
' -Typically this will not be provided on initial call, and is used
' during recursive calls to store all relevant results for output
'
'Author: tigeravatar on stackoverflow at https://stackoverflow.com/questions/56970854/loop-through-all-subfolders
'Created: July 10, 2019
'Static so that during recursive search it doesn't need to be recreated on every recursive call
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
'Check if arg_hResults was provided (typically not on first call, but will be on all subsequent recursive calls)
'This preserves all found matching file results throughout all recursive calls of the function
Dim hResults As Object
If arg_hResults Is Nothing Then Set hResults = CreateObject("Scripting.Dictionary") Else Set hResults = arg_hResults
'Variable used to store the folder path separator
Dim sPS As String
sPS = Application.PathSeparator
'Adjust so that even if folder path isn't passed with an ending Path Separator, the function can handle it appropriately
Dim sFolderPath As String
If Right(arg_sFolderPath, Len(sPS)) = sPS Then sFolderPath = arg_sFolderPath Else sFolderPath = arg_sFolderPath & sPS
'Verify the folder path provided is valid. Allow for hidden folders to be searched as well
If Len(Dir(sFolderPath, vbDirectory + vbHidden)) = 0 Then
MsgBox "Invalid directory path provided: " & Chr(10) & arg_sFolderPath, , "Search Directory Error"
Set SearchDirectory = Nothing
Exit Function
End If
'Using the FileSystemObject, work with the provided and validated folder path
Dim oFolder As Object
Set oFolder = oFSO.GetFolder(sFolderPath)
'Loop through all files in the folder
Dim oFile As Object
Dim bMatch As Boolean
For Each oFile In oFolder.Files
'Verify the file matches the provided search pattern (if any) according to case sensitivity
bMatch = False
If arg_bMatchCase = True Then
If oFile.Name Like arg_sSearch Then bMatch = True
Else
If LCase(oFile.Name) Like LCase(arg_sSearch) Then bMatch = True
End If
'If match found, add it to the hResults dictionary
If bMatch = True Then
If Not hResults.Exists(oFile.Path) Then hResults.Add oFile.Path, oFile.Path
End If
Next oFile
'If set to search subfolders (default behavior), have the function recursively call itself to search all subfolders
If arg_bIncludeSubFolders = True Then
Dim oSubFolder As Object
For Each oSubFolder In oFolder.SubFolders
Set hResults = SearchDirectory(oSubFolder.Path, arg_sSearch, arg_bMatchCase, arg_bIncludeSubFolders, hResults)
Next oSubFolder
End If
'Set function output to the hResults dictionary if it contains any matched file results
If hResults Is Nothing Then
Set SearchDirectory = Nothing
Else
If hResults.Count = 0 Then Set SearchDirectory = Nothing Else Set SearchDirectory = hResults
End If
End Function
This is an example of how to use the function and work with its results:
Sub tgr()
'Create an object variable and set it to the function SearchDirectory
'Provide SearchDirectory arguments as desired
Dim hFoundFiles As Object
Set hFoundFiles = SearchDirectory("C:\Test")
'Verify it actually found files matching your criteria in the folder specified
If hFoundFiles Is Nothing Then Exit Sub 'Didn't return any results
'Can output results to a worksheet
ActiveWorkbook.ActiveSheet.Range("A1").Resize(hFoundFiles.Count).Value = Application.Transpose(hFoundFiles.Keys)
'Can loop through each result if you need to do something with them individually
Dim vFile As Variant
For Each vFile In hFoundFiles.Keys
'Do something here
Debug.Print vFile
Next vFile
End Sub
I need some help listing all the files and a specific folder. I used this tutorial and I cannot get it to work with the VBA.
Once on one drive, will this still work? If I follow the tutorial without VBA, the function doesn't list the file names...
Please help me.
Thanks,
VBA:
Function GetFileNames(ByVal FolderPath As String) As Variant
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim MyFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = MyFolder.Files
ReDim Result(1 To MyFiles.Count)
i = 1
For Each MyFile In MyFiles
Result(i) = MyFile.Name
i = i + 1
Next MyFile
GetFileNames = Result
End Function
Cell Function:
=IFERROR(INDEX(GetFileNames($A$1),ROW()-2),"")
A1:
=REPLACE(CELL("filename"),FIND("[",CELL("filename")),LEN(CELL("filename")),"*")
This actually prints out
https://...../Test/*
I had to remove the slash and * for it to work locally. But still not working on one drive
I recently got help here with the first function but I am stumped about why my code is not working..
I'm trying to use the ReportTimeByOP function to find the newest file located in "sFolder" that begins with "sName" and that has a "sOPID" that matches the "value38" result of the ReadTextFile function.
For whatever reason I have no trouble getting both functions to work independently but my attempts to combine them into one seamless operation have failed. What I currently have is:
Function ReadTextFile(fpath)
Dim fline As String
Dim fnumb As Long
Dim i As Long
Dim Wanted As String
fnumb = FreeFile
Open fpath For Input As #fnumb
i = 1
Do While Not EOF(fnumb)
Line Input #fnumb, fline
If i = 2 Then
Wanted = Split(fline, vbTab)(38)
Exit Do
End If
i = i + 1
Loop
Close #fnumb
MsgBox fpath
ReadTextFile = Wanted
End Function
Function ReportTimeByOP(ByVal sName As String, ByVal sFolder As String, ByVal sOPID As String)
Dim FileName As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
Dim value38 As String
Dim oFSO As FileSystemObject
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolder) Then
FileName = Dir(sFolder & sName & "*hdr.txt", 0)
If FileName <> "" Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(sFolder & FileName)
Do While FileName <> ""
value38 = ReadTextFile(sFolder & FileName)
If FileDateTime(sFolder & FileName) > MostRecentDate And Trim(value38) = Trim(sOPID) Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(sFolder & FileName)
value38 = ReadTextFile(sFolder & FileName)
End If
FileName = Dir
DoEvents
Loop
End If
Else
MostRecentFile = "Err: folder not found."
End If
Set oFSO = Nothing
ReportTimeByOP = MostRecentDate
End Function
Given the huge number of files, I'd skip the Dir function entirely. I'd also skip the manual sorting of the results by creation date (I'm assuming this is the criteria - if not, it should be fairly easy to modify). Let the Windows Shell do the heavy lift for you. Unlike the VBA Dir() function or the Scripting.FileSystemObject, the shell dir command has a ton of parameters that allow you to retrieve sorted output. For this purpose, going through a list of files sorted in reverse order is much, much more efficient. You can see all of the dir options here.
So, I'd approach this by shelling to a dir command that retrieves the list of files in reverse date order, pipe it to a temp file, and then pick up the temp file to go through the list. That way you can just exit when you find your first match. Then you can simplify both your loop and ReadTextFile function by using the FileSystemObject:
ReadTextFile:
Public Function ReadTextFile(target As File) As String
With target.OpenAsTextStream
If Not .AtEndOfStream Then .SkipLine
Dim values() As String
If Not .AtEndOfStream Then
values = Split(.ReadLine, vbTab)
If UBound(values) >= 38 Then
ReadTextFile = values(38)
End If
End If
.Close
End With
End Function
ReportTimeByOP:
Function ReportTimeByOP(ByVal sName As String, ByVal sFolder As String, _
ByVal sOPID As String) As Date
With New Scripting.FileSystemObject
Dim temp As String
temp = .BuildPath(.GetSpecialFolder(TemporaryFolder), .GetTempName)
Dim seeking As String
seeking = .BuildPath(sFolder, sName & "*hdr.txt")
Shell "cmd /c dir """ & seeking & """ /b /a:-d /o:-d > " & temp
'Shell is asychronous - wait .2 seconds for it to complete.
Sleep 200
With .GetFile(temp).OpenAsTextStream
Dim directory() As String
directory = Split(.ReadAll, vbNewLine)
.Close
End With
.DeleteFile temp
Dim i As Long
Dim value38 As String
Dim candidate As File
'Temp file will end with a newline, so the last element is empty.
For i = LBound(directory) To UBound(directory) - 1
Set candidate = .GetFile(.BuildPath(sFolder, directory(i)))
value38 = ReadTextFile(candidate)
If Trim$(value38) = Trim$(sOPID) Then
ReportTimeByOP = candidate.DateCreated
Exit Function
End If
Next i
End With
End Function
And this declaration somewhere:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
I have some files that are called Team-(Random Number).txt.
Dir("Team-" & "*" & ".txt")
But when there have been changes there could be text files called Team-(Random Number)-AAA.txt, Team-(Random Number)-AAB.txt and so but the most recent file is always called Team-(Random Number).txt.
Since Dir only returns 1 file and does this randomly is there a way to get the file Team-(Random Number).txt?
It should be no problem if dir returned the result in a normal order but apparently it does it randomly.
I've thought of excluding the -AAA part but don't know what the syntax should. Or in a less efficient way to get all files and sort it in an array but with 10 - 200 files it's not very efficient.
Now I'm hoping could give me the syntax of excluding the part or other workaround for my problem thanks!
I'd say go for Regular Expressions.
Private Sub TeamTxtExists()
Dim Path As String, Pattern As String, FileFound As String
Dim REGEX As Object, Matches As Object
Dim oFSO As Object, oFolder As Object, oFile As Object
Path = "D:\Personal\Stack Overflow\" 'Modify as necessary.
Pattern = "(Team-(\d+).txt)"
Set REGEX = CreateObject("VBScript.RegExp")
With REGEX
.Pattern = Pattern
.Global = True
.IgnoreCase = True
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(Path)
For Each oFile In oFolder.Files
Set Matches = REGEX.Execute(oFile.Name)
For Each Match In Matches
Debug.Print Match.Value
Next Match
Next oFile
End Sub
This will print in your immediate window (Ctrl-G in the VBE) all the names of text files that don't have AAA or the like in their filenames. Tried and tested.
In a similar vein to Loop through files in a folder using VBA?
Use Dir to efficiently find the first group of files that match team-xxxx.txt
Then zero in on the wanted match which could either be done with
Like for a simple match
Regexp for a harder match
Exit the Dir list on a successful match
I went with the regexp.
code
Sub LoopThroughFiles()
Dim objRegex As Object
Dim StrFile As String
Dim bFound As Boolean
bFound = False
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "team-\d+"
StrFile = Dir("c:\temp\team-*.txt")
Do While Len(StrFile) > 0
If objRegex.test(StrFile) = False Then
StrFile = Dir
Else
bFound = True
MsgBox "Your file is " & StrFile
Exit Do
End If
Loop
If Not bFound Then MsgBox "No Match", vbCritical
End Sub
Is this helping?:
Dir("Your_folder_path_ending_with_a_\" & "Team-(*).txt")
Going a bit more in-depth and using the folder content shown in the picture:
This sub will return all the file names that only contain "Team-(Random Number).txt":
Sub showFileName()
Dim FolderPath As String: FolderPath = "C:\test\"
Dim Filter As String: Filter = "Team-(*).txt"
Dim dirTmp As String
dirTmp = Dir(FolderPath & Filter)
Do While Len(dirTmp) > 0
Debug.Print dirTmp
dirTmp = Dir
Loop
End Sub
The result is:
Team-(123).txt
Team-(14).txt
Team-(PI).txt
Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
InputFolder = Application.GetOpenFilename("Folder, *")
Range("C1").Select
ActiveCell.Value = InputFolder & "\"
End Sub
I am using the code above to attempt to store, and then paste, a folder location for another macro I am running.
Any idea how to make it stop at the folder level or remove the filename from the end?
Thanks!
You could use
FileName = Dir(InputFolder)
InputFolder = Left(InputFolder, Len(InputFolder)-Len(FileName))
Dir() gets just the file name and Left() helps trim down the string to just the folder path.
There is even shorter option to get your path. Just with one single line:
'...your code
Dim InputFolder As String
InputFolder = Application.GetOpenFilename("Folder, *")
'new, single line solution
InputFolder = Mid(InputFolder, 1, InStrRev(InputFolder, Application.PathSeparator))
And I think there could be some more options available :)
If I understand right, you want to get the path to a file but you do not want to file name in the InputFolder string. If I understood correctly then this will do the trick:
Option Explicit
Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
InputFolder = Application.GetOpenFilename("Folder, *")
Range("C1").Value = getFilePath(InputFolder)
End Sub
Function getFilePath(path As String)
Dim filePath() As String
Dim finalString As String
Dim x As Integer
filePath = Split(path, "\")
For x = 0 To UBound(filePath) - 1
finalString = finalString & filePath(x) & "\"
Next
getFilePath = finalString
End Function
Also, you do not have to write the file name to the spreadsheet in order for another macro to get it. You can just call the other macro from your first macro and pass the file name as a parameter or set the file name variable as a module level variable so it can be accessed by the other macro, assuming that second macro is in the same module.
Wow, this board is incredible! I would up using casey's code and it worked perfectly :). I also added in a function to create subfolders as needed.
Here is the final product I settled on.
Option Explicit
Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
MsgBox ("Please Select the Folder of Origin")
InputFolder = Application.GetOpenFilename("Folder, *")
Range("D5").Value = getFilePath(InputFolder)
MsgBox ("Please Select the Desired Destination Root Folder")
InputFolder = Application.GetOpenFilename("Folder, *")
Range("E5").Value = getFilePath(InputFolder)
Dim OutputSubFolder As String
Dim Cell As Range
Range("E5").Select
OutputSubFolder = ActiveCell.Value
'Loop through this range which includes the needed subfolders
Range("C5:C100000").Select
For Each Cell In Selection
On Error Resume Next
MkDir OutputSubFolder & Cell
On Error GoTo 0
Next Cell
End Sub
Function getFilePath(path As String)
Dim filePath() As String
Dim finalString As String
Dim x As Integer
filePath = Split(path, "\")
For x = 0 To UBound(filePath) - 1
finalString = finalString & filePath(x) & "\"
Next
getFilePath = finalString
End Function