I need to get some information about some files so im trying to build a function that returns 3 information like this:
sub main()
File = getFile(path) 'future code to list all file information on range
end sub
Function getFile(ByVal path as String)
Dim result() as String
Dim Arquivo as File
Set Folder = FSO.getFolder(Path)
For Each File in Folder.Files
result(n) = File.Name
result2(n) = File.DateLastModified
result3(n) = File.ParentFolder
Next
getFile = Result(), Result2(),Result3()???
End function
Is it possible to return the 3 file information in a single funcion?
Get File Info
Option Explicit
Sub GetFileInfoTEST()
Const FolderPath As String = "C:\Test"
Const wsName As String = "Sheet1"
Const FirstCellAddress As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim FileInfo As Variant: FileInfo = GetFileInfo(FolderPath)
Dim rCount As Long: rCount = UBound(FileInfo, 1)
If IsEmpty(FileInfo) Then Exit Sub
With ws.Range(FirstCellAddress).Resize(, UBound(FileInfo, 2))
.Resize(rCount).Value = FileInfo
.Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).ClearContents
.EntireColumn.AutoFit
End With
End Sub
Function GetFileInfo( _
ByVal FolderPath As String) _
As Variant
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FolderPath) Then Exit Function
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
Dim fCount As Long: fCount = fsoFolder.Files.Count
If fCount = 0 Then Exit Function
Dim Data As Variant: ReDim Data(1 To fCount, 1 To 3)
Dim fsoFile As Object
Dim r As Long
For Each fsoFile In fsoFolder.Files
r = r + 1
Data(r, 1) = fsoFile.Name
Data(r, 2) = fsoFile.DateLastModified
Data(r, 3) = fsoFile.ParentFolder
Next fsoFile
GetFileInfo = Data
End Function
Please, try the next adapted function:
Function getFile(ByVal path As String) As Variant
Dim fso As Object, folder As Object, file As Object
Dim arrName, arrDat, arrPar, n As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(path)
ReDim arrName(folder.files.count - 1)
ReDim arrDat(folder.files.count - 1)
ReDim arrPar(folder.files.count - 1)
For Each file In folder.files
arrName(n) = file.name
arrDat(n) = file.DateLastModified
arrPar(n) = file.parentfolder
n = n + 1
Next
getFile = Array(arrName, arrDat, arrPar)
End Function
It can be tested in the next way:
Sub main()
Dim file As Variant, path As String
path = "the folder path" 'please use here a real path...
file = getFile(path) 'future code to list all file information on range
Debug.Print file(0)(0), file(1)(0), file(2)(0)
End Sub
Related
I've tried and search through out vba forum to figure out how can I rectify my code (below) to search files within a specific directory and its sub-directories to list and populated list of file that have 20 characters in filename length and just only pdf extension.
I want to list of file with no extension at the end in column A and full file path and name in column B.
Also tried to sort all files ascending after list created but no success yet :(
any help? Thanks
Sub ListPDF()
Range("A:L").ClearContents
Range("A1").Select
Dim strPath As String
strPath = "K:\Test\PDF\"
Dim OBJ As Object, Folder As Object, File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)
Call ListFiles(Folder)
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
Call ListFiles(SubFolder)
Call GetSubFolders(SubFolder)
Next SubFolder
Range("A1").Select
End Sub
Sub ListFiles(ByRef Folder As Object)
For Each File In Folder.Files
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0) = File.Name
ActiveCell.Offset(0, 1) = File.Path
Next File
End Sub
Sub GetSubFolders(ByRef SubFolder As Object)
Dim FolderItem As Object
For Each FolderItem In SubFolder.Subfolders
Call ListFiles(FolderItem)
Call GetSubFolders(FolderItem)
Next FolderItem
End Sub
Use this:
Option Explicit
Dim fso As Object, fsoFolder As Object, fsoSubFolder As Object, fsoFile As Object
Public Sub ListPDFs()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.UsedRange.ClearContents
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
ShowPDFs ThisWorkbook.Path & "\..", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Public Sub ShowPDFs(ByRef fsoPath As String, ByRef ws As Worksheet)
Dim lastCell As Range, pdfName As String
Set fsoFolder = fso.GetFolder(fsoPath)
For Each fsoFile In fsoFolder.Files
pdfName = fsoFile.Name
If Len(pdfName) > 20 Then
If InStr(1, pdfName, ".pdf") > 0 Then
pdfName = Left(pdfName, InStrRev(pdfName, ".") - 1)
Set lastCell = ws.Cells(ws.Rows.Count, 1).End(xlUp)
lastCell.Offset(1, 0) = pdfName
lastCell.Offset(1, 1) = fsoFile.Path
End If
End If
Next
For Each fsoSubFolder In fsoFolder.SubFolders
ShowPDFs fsoSubFolder.Path, ws
Next
End Sub
I have Excel-2007. I am using File System Object VBA code to list files in a directory. I have also set up reference to Microsoft Scriptlet Library in excel.
I am getting:
Compiler error:User-defined type not defined
on this very first code line
Dim FSO As Scripting.FileSystemObject
Code used by me as follows:
Sub ListFilesinFolder()
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
SourceFolderName = "C:\mydir"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("text file", "path", "Date Last Modified")
i = 2
For Each FileItem In SourceFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
End Sub
Can someone point out where am I going wrong?
**UPDATE -03-09-2015**
I have updated my program based on #brettdj program and some research to list all files including sub-folder files. It works for me. I look forward to suggestions to further improve it.
Sub ListFilesinFolder()
Dim objFSO As Object
Dim ws As Worksheet
Dim cl As Range
Dim objFolderName As String
objFolderName = "C:\FY_2015-2016\sunil"
Set objFSO = New Scripting.FileSystemObject
Set ws = ActiveSheet
With Range("A1:C1")
.Value2 = Array("File", "path", "Date Last Modified")
.Font.Bold = True
End With
Set cl = ws.Cells(2, 1)
ListFolders cl, objFSO.GetFolder(objFolderName)
Set objFSO = Nothing
End Sub
Sub ListFolders(rng As Range, Fol As Scripting.Folder)
Dim SubFol As Scripting.Folder
Dim FileItem As Scripting.File
' List Files
For Each FileItem In Fol.Files
rng.Cells(1, 1) = FileItem.Name
rng.Cells(1, 2) = FileItem.ParentFolder.Path
rng.Cells(1, 3) = FileItem.DateLastModified
Set rng = rng.Offset(1, 0)
Next
' Proces subfolders
For Each SubFol In Fol.SubFolders
ListFolders rng, SubFol
Next
With ActiveSheet
.Columns.EntireColumn.AutoFit
End With
End Sub
I am posting another update which is not cell by cell filling.
REVISED UPDATE ON 3-09-2015
Sub GetFileList()
Dim strFolder As String
Dim objFSO As Object
Dim objFolder As Object
Dim myResults As Variant
Dim lCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
strFolder = .SelectedItems(1)
End With
Set objFolder = objFSO.GetFolder(strFolder)
'the variable dimension has to be the second one
ReDim myResults(0 To 5, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(1, 0) = "Size"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified"
myResults(4, 0) = "Accessed"
myResults(5, 0) = "Full path"
'Send the folder to the recursive function
FillFileList objFolder, myResults, lCount
' Dump these to a worksheet
fcnDumpToWorksheet myResults
'tidy up
Set objFSO = Nothing
End Sub
Private Sub FillFileList(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim objFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
'load the array with all the files
For Each objFile In objFolder.Files
lCount = lCount + 1
ReDim Preserve myResults(0 To 5, 0 To lCount)
myResults(0, lCount) = objFile.Name
myResults(1, lCount) = objFile.Size
myResults(2, lCount) = objFile.DateCreated
myResults(3, lCount) = objFile.DateLastModified
myResults(4, lCount) = objFile.DateLastAccessed
myResults(5, lCount) = objFile.Path
Next objFile
'recursively call this function with any subfolders
Set fsoSubFolders = objFolder.SubFolders
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
'since we switched the array dimensions, have to transpose
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub
Would recommend using an array approach for speed
Sub ListFilesinFolder()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim lngCnt As Long
Dim X
objFolderName = "C:\temp"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(objFolderName)
ReDim X(1 To objFolder.Files.Count, 1 To 3)
For Each objFile In objFolder.Files
lngCnt = lngCnt + 1
X(lngCnt, 1) = objFile.Name
X(lngCnt, 2) = objFile.Path
X(lngCnt, 3) = Format(objFile.DateLastModified, "dd-mmm-yyyy")
Next
[a2].Resize(UBound(X, 1), 3).Value2 = X
With Range("A1:C1")
.Value2 = Array("text file", "path", "Date Last Modified")
.Font.Bold = True
.Columns.EntireColumn.AutoFit
End With
End Sub
You're referencing Microsoft Scriptlet Library; should be Microsoft Scripting Runtime.
Try this:
Sub ListFilesinFolder()
Dim FSO
Dim SourceFolder
Dim FileItem
SourceFolderName = "C:\mydir"
Set FSO = CreateObject("Scripting.FileSystemObject") '<-- New change
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("text file", "path", "Date Last Modified")
i = 2
For Each FileItem In SourceFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
End Sub
I'm trying to get the one Before the Last modified File in a Folder Using Excel VBA, I have managed to Get the Last Modified File, But I couldn't get the second one.
Herein Below the code I used to get the Last Modified File, without using system Functions or built-in function.
Sub LastFileModified()
Dim fso As New Scripting.FileSystemObject
Dim fill As Scripting.File
Dim i As Integer
Dim ForStep As Integer
Dim Arr() As Variant
ReDim Arr(fso.GetFolder("C:\Users\Shahim\Desktop\xxxx").Files.Count - 1, 1) As Variant
i = 0
For Each fill In fso.GetFolder("C:\Users\Shahim\Desktop\xxxx").Files
Arr(i, 0) = fill.Name
Arr(i, 1) = CDbl(fill.DateLastModified)
i = i + 1
Next fill
Dim filename As String
Dim Initializer As Double
Initializer = Arr(0, 1)
For ForStep = LBound(Arr) To UBound(Arr)
If Arr(ForStep, 1) > Initializer Then
Initializer = Arr(ForStep, 1)
filename = Arr(ForStep, 0)
End If
Next ForStep
Debug.Print filename
Erase Arr
End Sub
Sub SecodLastModified()
Const FLDR_PATH As String = "C:\Test"
Dim i As Long, j As Long, fileArr() As String, maxFiles As Long
Dim fso As Variant, fldr As Variant, f As Variant, l1 As String, l2 As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder(FLDR_PATH)
maxFiles = fldr.Files.Count
ReDim fileArr(1 To maxFiles, 1 To 2)
i = 1
For Each f In fldr.Files
fileArr(i, 1) = f.Name
fileArr(i, 2) = f.DateLastModified
i = i + 1
Next
For i = 1 To maxFiles
For j = i + 1 To maxFiles
If fileArr(j, 2) > fileArr(i, 2) Then
l1 = fileArr(i, 2)
l2 = fileArr(i, 1)
fileArr(i, 2) = fileArr(j, 2)
fileArr(i, 1) = fileArr(j, 1)
fileArr(j, 2) = l1
fileArr(j, 1) = l2
End If
Next
Next
MsgBox fileArr(2, 1)
End Sub
The original answer did not work for me for two reasons.
fileArr(i,2) was not declared a date, and occassionally Excel could not decipher what was the greater date. When I tried to dim this as a date, it said I could not dim an Array.
If temporary files were included, it did not skip over those files.
Here is what worked for me.
Function SecodLastModified(Directory)
Dim FileSys As FileSystemObject
Dim objFile As File, objFile1 As File
Dim myFolder
Dim strFilename As String, strFolder As String, myDir As String
Dim strFilenameFirst As String, strFilenameSecond As String, strFilenameSecond1 As String
Dim dteFile As Date, dteFileSecond1 As Date, dteFileFirst As Date, dteFileSecond As Date
Dim openLastFile
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(Directory)
dteFileSecond1 = DateSerial(1900, 1, 1)
dteFile = DateSerial(1900, 1, 1)
'loop through each file and get date last modified. If largest date then store Filename
For Each objFile In myFolder.Files
For Each objFile1 In myFolder.Files
' To prevent opening temporary files
If objFile1.Name Like "*.xlsx" And Left(objFile1.Name, 2) <> "~$" Then
If objFile1.DateLastModified > objFile.DateLastModified Then
dteFileSecond = objFile.DateLastModified
strFilenameSecond = objFile.Name
dteFileFirst = objFile1.DateLastModified
strFilenameFirst = objFile1.Name
' If second file date is greater than current second file, store away as the second file
If dteFileSecond > dteFileSecond1 Then
dteFileSecond1 = objFile.DateLastModified
strFilenameSecond1 = objFile.Name
End If
End If
End If
Next
Next objFile
Set SecodLastModified = Workbooks.Open(Directory & "\" & strFilenameSecond1)
Set FileSys = Nothing
Set myFolder = Nothing
End Function
Excel 2010 VBA: I'm trying to loop through files in a folder and only open the files with names that contain a certain string. I've done this before and I know the logic works, but I keep getting the 424 error when I'm opening the target files. I'm pretty sure it has something to do with the links and have tried EVERYTHING to turn off those alerts problematically, but I'm still getting the error
Private Sub CommandButton1_Click()
Dim lSecurity As Long
Dim myPath As Variant
lSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
myPath = "F:\Pathname"
Call Recurse(myPath)
Application.AutomationSecurity = lSecurity
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
Function Recurse(sPath As Variant) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As Variant
Dim file As String
Dim A As Workbook
Dim B As Workbook
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim count As Integer
Set myFolder = FSO.GetFolder(sPath)
Set A = ThisWorkbook
i = 2
For Each myFile In myFolder.Files
If InStr(myFile.Name, "_2015_DOMESTIC_TB") <> 0 Then
Set B = Workbooks.Open(Filename:=myFile)
Call Datadump
B.Close SaveChanges:=False
End If
i = i + 1
Next
End Function
Function Datadump()
A.Cells(i, 1).Value = B.Cells(1, 4).Value
For count = 1 To 59
k = 2
A.Cells(i, k).Value = B.Cells(11 + count, 4).Value
count = count + 1
k = k + 1
Next count
End Function
Seems like your function is trying to open a non Excel file. Change your function to (Untested as posting from phone)
Function Recurse(sPath As Variant) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As Variant
Dim file As String
Dim A As Workbook, B As Workbook
Dim i As Integer, j As Integer, k As Integer, count As Integer
Dim MyAr As Variant
Set myFolder = FSO.GetFolder(sPath)
Set A = ThisWorkbook
i = 2
For Each myFile In myFolder.Files
If InStr(myFile.Name, "_2015_DOMESTIC_TB") <> 0 Then
MyAr = Split(myFile.Name, ".")
If MyAr(UBound(MyAr)) Like "xls*" Then '<~~ Check if it is an Excel file
Set B = Workbooks.Open(Filename:=myFile.Name)
Call Datadump
B.Close SaveChanges:=False
End If
End If
i = i + 1
Next
End Function
This function will check that you are trying to open a valid excel file.
If you still get the error then please tell us which line is giving you the error and what is the value of myFile.Name at the time of error.
I have a file name of a pdf that I want to search for in a folder on a shared network drive \\Share\Projects. The pdf will be in one of the subfolders under projects. I then want to return the entire file path of the pdf into a cell (eg \\Share\Projects\Subfolder\Another subfolder\thisone.pdf).
I have started the code but can't figure out how to search a file system:
Sub InsertPath()
Dim PONumber As String
PONumber = InputBox("PO Number:", "PO Number")
'search for order
Dim myFolder As Folder
Dim myFile As File
'This bit doesn't work
Set myFolder = "\\Share\Projects"
For Each myFile In myFolder.Files
If myFile.Name = "PO" & PONumber & ".pdf" Then
'I have absolutely no idea how to do this bit
End If
Next
End Sub
Am I on the right track or is my code completely wrong?
get list of subdirs in vba
slighly modified the above post.
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim i As Long
Dim j As Long
Dim MyFile As String
Const strPath As String = "C:\Personal\" ' change it as per your needs
myArr = GetSubFolders(strPath)
Application.ScreenUpdating = False
Range("A1:B1") = Array("text file", "path")
For j = LBound(Arr) To UBound(Arr)
MyFile = Dir(myArr(j) & "\*.pdf")
Do While Len(MyFile) <> 0
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = myArr(j)
MyFile = Dir
Loop
Next j
Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
Counter = Counter + 1
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
Well, your folder declaration isn't set against a filesystemobject so it can't find the folder. And because it's a network location, you may need to map a network drive first so that it's a secure link.
So here's an updated version of your code.
EDIT - to OP's conditions.
Dim PONumber As String
Sub InsertPath()
PONumber = InputBox("PO Number:", "PO Number")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Servershare As String
ServerShare = "S:\"
Dim Directory As Object
Set Directory = fso.GetFolder(ServerShare)
Subfolderstructure Directory
End Sub
Function Subfolderstructure(Directory As Object)
For Each oFldr in Directory.SubFolders
For Each FileName In oFldr.Files
If FileName.Name = "PO" & PONumber & ".pdf" Then
sheets("Sheet1").range("A1").value = ServerShare & "\PO" & PONumber & ".pdf"
Exit For
End If
Next
Dim sbfldrs : Set sbfldrs = ofldr.SubFolders
If isarray(sbfldrs) then
Subfolderstructure ofldr
End if
Next
'Cleanup
Set FileName = Nothing
Set Directory = Nothing
Set fso = Nothing
End Function
I have not tested this code. Try it out and let me know how it works.