Is there method similar to 'Find' available when we Loop through folder (of files) using Dir Function in excel vba? - vba

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

Related

How to populate last saved user and last saved date of a file

I have the code below to get file names from folders.
Sub GetFileNames_Assessed_As_T2()
Dim sPath As String, sFile As String
Dim iRow As Long, iCol As Long
Dim ws As Worksheet: Set ws = Sheet9
'declare and set the worksheet you are working with, amend as required
sPath = "Z:\NAME\T2\"
'specify directory to use - must end in ""
sFile = Dir(sPath)
Do While sFile <> ""
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row 'get last row on Column I
Filename = Left(sFile, InStrRev(sFile, ".") - 1) 'remove extension from file
Set FoundFile = ws.Range("I1:I" & LastRow).Find(what:=Filename, lookat:=xlWhole) 'search for existing filename
If FoundFile Is Nothing Then ws.Cells(LastRow + 1, "I") = Filename 'if not found then add it
sFile = Dir ' Get next filename
Loop
End Sub
I need an adjustment to fetch the following and populate it on the spreadsheet:
File last updated by (Column O)
File last updated date (Column P)
Hyperlink the file to the spreadsheet (Column Q)
Here is an example accessing the extended document properties via Dsofile.dll. 32 bit version is here. I am using re-written 64 bit alternative by robert8w8. After installation, of 64 bit version in my case, you go Tools >References >Add a reference to DSO OLE Document Properties Reader 2.1. It enables to access extended properties of closed files. Obviously, if the info is not available, it cannot be returned.
I have an optional filemask test in there which can be removed.
The DSO function is my re-write of a great sub that lists many more properties by xld here.
Option Explicit
Public Sub GetLastestDateFile()
Dim FileSys As Object, objFile As Object, myFolder As Object
Const myDir As String = "C:\Users\User\Desktop\TestFolder" '< Pass in your folder path
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set myFolder = FileSys.GetFolder(myDir)
Dim fileName As String, lastRow As Long, arr(), counter As Long
With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet where writing info to
lastRow = .Cells(.Rows.Count, "P").End(xlUp).Row 'find the last row with data in P
For Each objFile In myFolder.Files 'loop files in folder
fileName = objFile.Path
If FileSys.GetExtensionName(fileName) = "xlsx" Then 'check if .xlsx
arr = GetExtendedProperties(fileName)
counter = counter + 1
.Cells(lastRow + counter, "O") = arr(0) 'Last updated
.Cells(lastRow + counter, "P") = arr(1) 'Last save date
.Hyperlinks.Add Anchor:=.Cells(lastRow + counter, "Q"), Address:=objFile.Path '<== Add hyperlink
End If
Next objFile
End With
End Sub
Public Function GetExtendedProperties(ByVal FileName As String) As Variant
Dim fOpenReadOnly As Boolean, DSO As DSOFile.OleDocumentProperties
Dim oSummProps As DSOFile.SummaryProperties, oCustProp As DSOFile.CustomProperty
Dim outputArr(0 To 1)
Set DSO = New DSOFile.OleDocumentProperties
DSO.Open FileName, fOpenReadOnly, dsoOptionOpenReadOnlyIfNoWriteAccess
Set oSummProps = DSO.SummaryProperties
outputArr(0) = oSummProps.LastSavedBy
outputArr(1) = oSummProps.DateLastSaved
GetExtendedProperties = outputArr
End Function
Other:
Hyperlinks.Add method
In my case I could not use the DSO library from dsofile.dll (one needs to be admin to install it and register it...), so I came up with another solution to get some OLE properties of Office documents without opening them. It appears that (some of?) these Extended Properties are also accessible via the Shell:
Function GetDateLastSaved_Shell32(strFileFullPath$)
strFolderPath$ = Left(strFileFullPath, Len(strFileFullPath) - Len(Dir(strFileFullPath)))
strFileName$ = Dir(strFileFullPath)
'using late binding here
'to use early binding with Dim statements you need to reference the Microsoft Shell Controls And Automation library, usually available here:
'C:\Windows\SysWOW64\shell32.dll
'Example:
'Dim shlShell As Shell32.Shell
Set shlShell = CreateObject("Shell.Application") 'Variant/Object/IShellDispatch6
'Set shlFolder = shlShell.Namespace(strFolderPath) 'does not work when using late binding, weird...*
Set shlFolder = shlShell.Namespace(CStr(strFolderPath)) 'works...
'Set shlFolder = shlShell.Namespace(strFolderPath & "") 'works...
'Set shlFolder = shlShell.Namespace(Left$(strFolderPath, Len(strFolderPath))) 'works...
'*also mentioned here without an explanation...
'https://stackoverflow.com/questions/35957930/word-vba-shell-object-late-binding
Set shlShellFolderItem = shlFolder.ParseName(strFileName)
'all of the following returns the same thing (you have the returned Data Type indicated on the right)
'but the first one is said by MSDN to be the more efficient way to get an extended property
GetDateLastSaved_Shell32 = shlShellFolderItem.ExtendedProperty("{F29F85E0-4FF9-1068-AB91-08002B27B3D9} 13") 'Date
'GetDateLastSaved_Shell32 = shlShellFolderItem.ExtendedProperty("System.Document.DateSaved") 'Date
'GetDateLastSaved_Shell32 = shlShellFolderItem.ExtendedProperty("DocLastSavedTm") 'Date 'legacy name
'GetDateLastSaved_Shell32 = shlFolder.GetDetailsOf(shlShellFolderItem, 154) '?String?
End Function
To list all extended properties (Core, Documents, etc.), you can use this:
For i = 0 To 400
vPropName = shlFolder.GetDetailsOf(Null, i)
vprop = shlFolder.GetDetailsOf(shlShellFolderItem, i)
Debug.Print i, vPropName, vprop
If i Mod 10 = 0 Then Stop
Next
You can find more info about the "efficient way" on MSDN: ShellFolderItem.ExtendedProperty method
You can also find the list of FMTIDs and PIDSIs in propkey.h from Windows SDK or somewhere in C:\Program Files (x86)\Windows Kits\10\Include\***VERSION***\um\ if you have Visual Studio installed.

Running List of CMD lines from Excel

Can anyone help please with the following requirements?
Requirement A:
I'd like to create a loop to run a list of command strings in CMD as long as there's a non-zero value in column C. I think I need to define a variable i for my starting row as this will always be the same, and then run Shell(), pulling the command string from the corresponding cell in Row i, Column F. While Cells(i, "C") is not blank, keep going, increasing i by 1.
Requirement B:
I'd also like to link this macro to work in a directory deposited in a cell by an earlier macro that listed all the files in a selected directory.
This is what I have, without any looping..
Sub Run_Renaming()
Dim CommandString As Long
Dim i As Integer
i = 5
'Other steps:
'1 - need to pick up variable (directory of files listed, taken from first macro
'when doing manually, I opened command, went to correct directory, then pasted
'the commands. I'm trying to handle pasting the commands. I'm not sure if I need
'something to open CMD from VBA, then run through the below loop, or add opening
'CMD and going to the directory in each iteration of the below loop...
'2 - Need to say - Loop below text if Worksheets("Batch Rename of Files").Cells(i, "C").Value is no blank
CommandString = Worksheets("Batch Rename of Files").Cells(i, "F").Value
Call Shell("cmd.exe /S /K" & CommandString, vbNormalFocus)
'Other steps:
'3 - need to increase i by 1
'4 - need to check if C column is blank or not
'5 - need to end of C column is blank
End Sub
Background:
I'm creating a file renaming tool for a friend. They can use excel, but no programming languages or command prompt. Because of this, I don't want to have any steps, like creating a batch file suggested here, that would complicate things for my friend.
I've created an excel file with:
Tab 1 - a template sheet to create a new file name list. Works by concatenating several cells, adding a filetype, and outputting to a range of cells. Tab two links to this range when creating the renaming command strings for CMD
Tab 2 -
Button 1 - Sub rename() below. VBA to list files in a selected directory in Column C
Column F creates a command line that will rename File A as File B based on inputs to Tab 1 i.e. ren "File 1" "A1_B1_C1.xlsx"
Button 2 - Refers to a renaming macro (requirement 1 and 2 above) that picks up the selected directory from Button 1 and runs through all the renaming command strings while in that directory
Sub rename()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
Worksheets("Batch Rename of Files").Activate
Worksheets("Batch Rename of Files").Range("C4").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
Caveats:
1) I am not entirely clear on how you data etc is laid out so i am offering a way of achieving your goal that involves the elements i am clear on.
2) To be honest, personally, i would do as much using arrays or a dictionary as possible rather than going backwards and forwards to worksheets.
However...
Following the outline of your requirements and a little rough and ready, we have:
1) Using your macro rename (renamed as ListFiles and with a few minor tweaks) to write the chosen folder name out to Range("A1") in Worksheets("Batch Rename of Files") and the file names to Column C.
2) Using a second macro RenameFiles to pick up the rename shell commands from Column F of Worksheets("Batch Rename of Files"); write these out to a batch file on the desktop; add an additional first line command that sets the working directory to the chosen folder given in Range("A1") (Requirement A). The shell command executes the .bat file, completes the renaming (Requirement B) and then there is a line to remove the .bat file.
I am guessing this is a more efficient way of achieving your goal than looping the column F range executing a command one at a time.
I have not sought to optimize code in any further ways (i have added a few existing typed functions.) There are a number of other improvements that could be made but this was intended to help you achieve your requirements.
Let me know how it goes!
Tab1 layout (Sheet containing new file names):
Batch Rename of Files layout (Sheet containing output of the first macro and the buttons ):
Layout of Worksheet Batch Rename of File
In a standard module called ListFiles:
Option Explicit
Public Sub ListFilesInDirectory()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$ 'type hints not really needed
Dim wb As Workbook
Dim wsTab2 As Worksheet
Set wb = ThisWorkbook
Set wsTab2 = wb.Worksheets("Batch Rename of Files")
InitialFoldr$ = "C:\"
Dim lastRow As Long
lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row
wsTab2.Range("C4:C" & lastRow).ClearContents 'Get rid of any existing file names
wsTab2.Range("C4").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
wsTab2.Range("A1") = xDirect$
Do While xFname$ <> vbNullString
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
In a standard module called FileRenaming:
Option Explicit
Sub RenameFiles()
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim strFile As String
Dim strPath As String
Dim strData As Range
Dim wb As Workbook
Dim wsTab2 As Worksheet
Dim currRow As Range
Set wb = ThisWorkbook
Set wsTab2 = wb.Worksheets("Batch Rename of Files")
strPath = wsTab2.Range("A1").Value2
If strPath = vbNullString Then
MsgBox "Please ensure that Worksheet Batch Rename of Files has a directory path in cell A1"
Else
If Right$(Trim$(strPath), 1) <> "\" Then strPath = strPath & "\"
strFile = "Rename.bat"
Dim testString As String
Dim deskTopPath As String
deskTopPath = Environ$("USERPROFILE") & "\Desktop" 'get desktop path as this is where .bat file will temporarily be saved
testString = fso.BuildPath(deskTopPath, strFile) 'Check if .bat already exists and delete
If Len(Dir(testString)) <> 0 Then
SetAttr testString, vbNormal
Kill testString
End If
Set stream = fso.CreateTextFile(deskTopPath & "\" & strFile, True) 'create the .bat file
Dim lastRow As Long
lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row
Set strData = wsTab2.Range("F4:F" & lastRow) 'Only execute for as many new file names as present in Col C (in place of your until blank requirement)
stream.Write "CD /D " & strPath & vbCrLf
For Each currRow In strData.Rows 'populate the .dat file
stream.Write currRow.Value & vbCrLf
Next currRow
stream.Close
Call Shell(testString, vbNormalFocus)
Application.Wait (Now + TimeValue("0:00:01")) 'As sometime re-naming doesn't seem to happen without a pause before removing .bat file
Kill testString
MsgBox ("Renaming Complete")
End If
End Sub
Buttons code in Worksheet Batch Rename of Files
Private Sub CommandButton1_Click()
ListFilesInDirectory
End Sub
Private Sub CommandButton2_Click()
RenameFiles
End Sub
Example .bat file contents:
VERSION 2
And here is a different version using a dictionary and passing parameters from one sub to another. This would therefore be a macro associated with only one button push operation i.e. there wouldn't be a second button. The single button would call ListFiles which in turn calls the second macro. May require you to go in to tools > references and add in Microsoft Scripting Runtime reference.
Assumes you have a matching number of new file names in Col D of tab 1 as the number of files found in the folder (as per your script to obtain files in folder). I have removed the obsolete type references.Shout out to the RubberDuck VBA add-in crew for the add-in picking these up.
In one standard module:
Option Explicit
Public Sub ListFiles()
Dim xDirect As String, xFname As String, InitialFoldr As String
Dim wb As Workbook
Dim ws As Worksheet
Dim dict As New Scripting.Dictionary
Dim counter As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Tab1") 'Worksheet where new file names are
counter = 4 'row where new file names start
InitialFoldr = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
.Show
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
xFname = Dir(xDirect, 7)
Do While xFname <> vbNullString
If Not dict.Exists(xFname) Then
dict.Add xFname, ws.Cells(counter, "D") 'Or which ever column holds new file names. This add to the dictionary the current name and new name
counter = counter + 1
xFname = Dir
End If
Loop
End If
End With
RenameFiles xDirect, dict 'pass directory path and dictionary to renaming sub
End Sub
In another standard module:
Public Sub RenameFiles(ByVal folderpath As String, ByRef dict As Dictionary)
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim strFile As String
Dim testString As String
Dim deskTopPath As String
strFile = "Rename.bat"
deskTopPath = Environ$("USERPROFILE") & "\Desktop"
testString = fso.BuildPath(deskTopPath, strFile)
'See if .dat file of same name already on desktop and delete (you could overwrite!)
If Len(Dir(testString)) <> 0 Then
SetAttr testString, vbNormal
Kill testString
End If
Set stream = fso.CreateTextFile(testString, True)
stream.Write "CD /D " & folderpath & vbCrLf
Dim key As Variant
For Each key In dict.Keys
stream.Write "Rename " & folderpath & key & " " & dict(key) & vbCrLf 'write out the command instructions to the .dat file
Next key
stream.Close
Call Shell(testString, vbNormalFocus)
Application.Wait (Now + TimeValue("0:00:01")) 'As sometime re-naming doesn't seem to happen without a pause before removing .bat file
Kill testString
' MsgBox ("Renaming Complete")
End Sub
Scripting run time reference:
Adding runtime reference
Additional method for finding the desktop path. Taken from Allen Wyatt:
In a standard module add the following:
Public Function GetDesktop() As String
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
End Function
Then in the rest of the code replace any instances of deskTopPath =..... e.g.:
deskTopPath = Environ$("USERPROFILE") & "\Desktop"
With
desktopPath = GetDesktop

Loop Through All Subfolders - VBA - Queue method

I've made use of Cor_blimey's queue method to write all the folders and subfolders of a drive to an excel sheet, as follows:
Public Sub NonRecursiveMethod()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("your folder path variable") 'obviously replace
Do While queue.Count > 0
Set oFolder = queue(queue.count)
queue.Remove(queue.count) 'dequeue
'...insert any folder processing code here...'
'*...(Here I write the name of the folder to the excel sheet)*.
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
'...insert any file processing code here...
Next oFile
Loop
End Sub
I've tried the "LIFO" version (as above) and the "FIFO" version, but neither of them produces a standard alphabetical listing. The above version lists the drive in exact reverse alphabetical order, and the "FIFO" version produces a list in normal alphabetical order, but it lists only the first-level folders, then starts again and lists all the second-level folders, again in alphabetical order, then the third level of folders, again starting over from "A", etc. As a result, the subfolders are not listed under their parent folder.
Does anyone know what I can do to get a standard tree structure, in alphabetical order by folder and subfolder name?
TIA
Les
Update: for some reason I can't manage to show all the comments on this thread or write a new comment. But I wanted to thank everybody, in particular #Rosenfeld, and say that I'm eager to try the solution using dir but am currently swamped with work. I'll report back in a few days when I get a chance to stumble around.
I'd like for the output to the sheet to look like the results of a tree command
Seems to me the simplest would be to just use the Tree command.
Here is one way, but the details could certainly be changed:
Execute a Tree command on the base folder
Write the output to some text file (location and name specified in the code)
Open the file as a text file in Excel
Split into columns on the vertical bar (Unicode character 9474) that the Tree command uses to differentiate levels
I use the WSH.Run method as that allows the CMD window to be easily hidden
One could use the WSH.Exec method to pipe the output directly to a VBA variable, but it is much harder to hide the CMD window (meaning, in another application, I've not been able to) :-)
One could also Import the text file into the same workbook instead of opening a new file. I will leave that exercise to you if you choose to do it.
Option Explicit
'set referennce to Windows Script Host Object Model
Sub DirTree()
Dim sBaseFolder As String, sTempFile As String
Dim WSH As WshShell
Dim sCMD As String
Dim lErrCode As Long
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\Tree.txt"
'Command line
sCMD = "CMD /c tree """ & sBaseFolder & """ > """ & sTempFile & """"
Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)
If Not lErrCode = 0 Then
MsgBox "Error in execution: Code - " & lErrCode
Else
'Open the file
Workbooks.OpenText Filename:=sTempFile, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
FieldInfo:=Array(Array(1, 1), Array(2, 1))
End If
End Sub
Here is a screenshot of the beginning of the output when run on my C: drive
EDIT: Since you now mention that you want the links to be clickable, an approach using dir would probably be simpler, especially since you can provide arguments to the dir command that will result in full paths being returned.
I used a class module so as to have a User Defined Object, which would have the necessary information; and a dictionary of these objects after appropriate filtering.
I chose to display merely the folder name in the cell, but the the screen tip will show the full path.
Note the References that need to be set (in the code). Also note that the class module must be renamed: cTree
EDIT 2: The Regular and Class modules were edited to allow for optional listing of the files. Note that the macro now has an argument, so it must be called from another macro or from the immediate window, to include the argument. (The argument could also be obtained from an Input box, user form, etc, but I did it this way for now because it is simpler.
I did not add hyperlinks for the files, thinking it would get confusing as different programs and dialogs (other than the file explorer) would be opening depending on the extension.
Class Module
Option Explicit
'Rename Class Module: cTree
Private pFullPath As String
Private pFolderName As String
Private pLevel As Long
Private pFile As String
Private pFiles As Dictionary
Public Property Get FullPath() As String
FullPath = pFullPath
End Property
Public Property Let FullPath(Value As String)
pFullPath = Value
End Property
Public Property Get FolderName() As String
FolderName = pFolderName
End Property
Public Property Let FolderName(Value As String)
pFolderName = Value
End Property
Public Property Get Level() As Long
Level = pLevel
End Property
Public Property Let Level(Value As Long)
pLevel = Value
End Property
Public Property Get Files() As Dictionary
Set Files = pFiles
End Property
Public Function ADDfile(Value As String)
pFiles.Add Value, Value
End Function
Private Sub Class_Initialize()
Set pFiles = New Dictionary
pFiles.CompareMode = TextCompare
End Sub
Regular Module
Option Explicit
'Set reference to Windows Script Host Object Model
' Microsoft Scripting Runtime
Sub GetDirList(bInclFiles As Boolean)
Const sDIRargs As String = " /A-S-L-H /S"
Dim sBaseFolder As String, sTempFile As String
Dim WSH As WshShell
Dim sCMD As String
Dim lErrCode As Long
Dim FSO As FileSystemObject, TS As TextStream
Dim S As String, sFN As String
Dim V As Variant, W As Variant
Dim I As Long
Dim lMaxLevel As Long
Dim lMinLevel As Long
Dim dctTrees As Dictionary, cT As cTree
Dim wsRes As Worksheet
Dim vRes As Variant, rRes As Range
'Add worksheet if needed
On Error Resume Next
Set wsRes = Worksheets("TreeLink")
If Err.Number = 9 Then
Set wsRes = Worksheets.Add
wsRes.Name = "TreeLink"
End If
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\DirList.txt"
'CommandLine
sCMD = "CMD /c dir """ & sBaseFolder & """" & sDIRargs & " > " & sTempFile
Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)
If Not lErrCode = 0 Then
MsgBox "Error in execution: Code - " & lErrCode
Stop
Else
'Read in the relevant data
Set dctTrees = New Dictionary
Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sTempFile, ForReading, False, TristateUseDefault)
lMaxLevel = 0
V = Split(TS.ReadAll, vbCrLf)
For I = 0 To UBound(V)
Do Until V(I) Like " Directory of *"
If I = UBound(V) Then Exit For
I = I + 1
Loop
Set cT = New cTree
S = Mid(V(I), 15)
'Can exclude certain directories at this point
'To exclude all that start with a dot:
If Not S Like "*\.*" Then
With cT
.FullPath = S
.FolderName = Right(S, Len(S) - InStrRev(S, "\"))
.Level = Len(S) - Len(Replace(S, "\", ""))
lMaxLevel = IIf(lMaxLevel > .Level, lMaxLevel, .Level)
dctTrees.Add Key:=S, Item:=cT
I = I + 1
'Only run for file list
If bInclFiles = True Then
Do
sFN = V(I)
If Not sFN Like "*<DIR>*" _
And sFN <> "" Then
'add the files
dctTrees(S).ADDfile Mid(sFN, 40)
End If
I = I + 1
Loop Until V(I) Like "*# File(s)*"
End If
End With
End If 'End of directory exclusion "if" statement
Next I
lMinLevel = dctTrees(dctTrees.Keys(0)).Level
I = 0
With rRes.Resize(columnsize:=lMaxLevel + 1).EntireColumn
.Clear
.HorizontalAlignment = xlLeft
End With
Application.ScreenUpdating = False
For Each V In dctTrees.Keys
Set cT = dctTrees(V)
With cT
I = I + 1
rRes.Worksheet.Hyperlinks.Add _
Anchor:=rRes(I, .Level - lMinLevel + 1), _
Address:="File:///" & .FullPath, _
ScreenTip:=.FullPath, _
TextToDisplay:=.FolderName
For Each W In .Files.Keys
I = I + 1
rRes(I, .Level - lMinLevel + 2) = W
Next W
End With
Next V
Application.ScreenUpdating = True
End If
End Sub
Results without File Listing
Results with File Listing
I know you are using a non-recursion method, but admittedly I wanted to try my hand at using recursion to solve the task (particularly for anyone who may need this in the future).
Note: I am not certain that the Scripting.FileSystem Folders/Files collections are always alphabetical so I am assuming they are in this case, but I could be mistaken.
From brief tests I am not noticing any kind of performance issue with recursion though, depending on the directory size, there certainly could be one.
Finally, the 'CleanOutput' argument in the main Function is used to determine if hierarchy relationships are displayed in the output.
Method Used to Test/Output
Sub Test()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Set Folder = fso.GetFolder("C:")
Dim Test As Variant
Test = GetDirectoryFromScriptingFolder(Folder, True)
ActiveSheet.Range("A1").Resize(UBound(Test, 1), UBound(Test, 2)).value = Test
End Sub
Main Function
Private Function GetDirectoryFromScriptingFolder(ByVal InputFolder As Scripting.Folder, Optional CleanOutput As Boolean = False) As Variant
' Uses recursion to return an organized hierarchy that represents files/folders in the input directory
Dim CurrentRow As Long
CurrentRow = 1
Dim CurrentColumn As Long
CurrentColumn = 1
Dim OutputDirectory As Variant
ReDim OutputDirectory(1 To GetDirectoryLength(InputFolder), 1 To GetDirectoryDepth(InputFolder))
WriteFolderHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn, CleanOutput
' Adjust current column so that files in the parent directory are properly indented
WriteFileHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn + 1, CleanOutput
GetDirectoryFromScriptingFolder = OutputDirectory
End Function
Functions Used in Recursion
Private Sub WriteFolderHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
If Not IsArray(InputHierarchy) Then Exit Sub
InputHierarchy(CurrentRow, CurrentColumn) = InputFolder.Name
CurrentRow = CurrentRow + 1
Dim StartRow As Long
Dim SubFolder As Folder
For Each SubFolder In InputFolder.SubFolders
' Use recursion to write the files/folders of each subfolder to the directory
StartRow = CurrentRow
WriteFolderHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 1, CleanOutput
WriteFileHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 2, CleanOutput
If CleanOutput Then
For StartRow = StartRow To CurrentRow
InputHierarchy(StartRow, CurrentColumn) = "||"
Next
End If
Next
End Sub
Private Sub WriteFileHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
If Not IsArray(InputHierarchy) Then Exit Sub
Dim SubFile As File
For Each SubFile In InputFolder.Files
' Write the Files to the Hierarchy
InputHierarchy(CurrentRow, CurrentColumn) = SubFile.Name
If CleanOutput Then InputHierarchy(CurrentRow, CurrentColumn - 1) = "--"
CurrentRow = CurrentRow + 1
Next
End Sub
Helper Functions (Depth and Length)
Private Function GetDirectoryLength(ByVal InputFolder As Scripting.Folder) As Long
Dim TotalLength As Long
' Include a base of 1 to account for the input folder
TotalLength = 1 + InputFolder.Files.Count
Dim SubFolder As Scripting.Folder
For Each SubFolder In InputFolder.SubFolders
' Add 1 to the total to account for the subfolder.
TotalLength = TotalLength + GetDirectoryLength(SubFolder)
Next
GetDirectoryLength = TotalLength
End Function
Private Function GetDirectoryDepth(ByVal InputFolder As Scripting.Folder) As Long
Dim TotalDepth As Long
Dim SubFolder As Scripting.Folder
Dim MaxDepth As Long
Dim NewDepth As Long
For Each SubFolder In InputFolder.SubFolders
NewDepth = GetDirectoryDepth(SubFolder)
If NewDepth > MaxDepth Then
MaxDepth = NewDepth
End If
Next
If MaxDepth = 0 Then MaxDepth = 1
' Add 1 for the Parent Directory
GetDirectoryDepth = MaxDepth + 2
End Function
What is essentially happening is this:
We take an input Folder and determine the dimensions of the hierarchy
for that file
Next, we define an output array using those dimensions.
Using a row counter and column counter, we allow the recursion functions to write their recursive results directly to the hierarchy
This hierarchy is returned, and the main routine puts this straight to the sheet
Next Steps that You Could Take
I noticed a few things doing this
There is no information other than the file name, which, depending on
the application, may make the method useless
All files are included
in the output, not just important ones (non-important files being
temp, hidden, etc.)
Even with the CleanOutput option there isn't an easy way of diagramming the relationships between parents and children.
Overall though this should suffice, depending on your needs. You can make adjustments as needed. If you have questions, just ask :).
I don't think LIFO or FIFO matters, just take a look at this idea.
Sub GetFilesInFolder(SourceFolderName As String)
'--- For Example:Folder Name= "D:\Folder Name\"
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
ii) User wants to get the list of all files inside a folder as well as Sub-folders
Copy and Paste the below Code and this will list down the list of all the files inside the folder as well as sub-folders. If there are other files which are there in some other Sub-folders then it will list down all files from each and Every Folders and Sub-folders.
Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)
'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
'Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
'--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.
If Subfolders = True Then
For Each SubFolder In SourceFolder.Subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
File Manager using Excel Macro in Excel Workbook
I have created one File Manager using the above Code. It basically fetches the list of Files from Folders and Sub-folders and list them. It fetches other details of the files as well like File Size, Last modified, path of the File, Type of the File and a hyperlink to open the file directly from the excel by clicking on that.
It looks something like below:
Here is the link to download the full Workbook.
http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/
Click on the button that is named 'Download Now'.

VBA Copyfile from and excel sheet : Invalid procedure call or argument (Error 5)

list file image
i want to copyfile from a list in excel sheet if there isn t any file their . But i have an error 5 in fso.CopyFile filepath, Destination .
I do not know what is the problem , can you help me
Set fso = CreateObject("scripting.filesystemobject")
Destination = "C:\Users\test\"
Set oFolder = fso.GetFolder(Destination)
Set workboo = Workbooks.Open("C:\Users\listing.xlsx")
Set worksh = workboo.Worksheets("List_File")
For j = 1 To 10
numrows = worksh.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To numrows
icol = 2 * j - 1
filepath = worksh.Cells(i, icol).Value
If Not fso.FileExists(Destination) Then
fso.CopyFile filepath, Destination
End If
Next
Next
workboo.Close
End Sub
Your code expect Destination to be a file, but it is a directory. FSO documentation tells you that:
If source contains wildcard characters or destination ends with a path separator (), it is assumed that destination is an existing
folder in which to copy matching files. Otherwise, destination is
assumed to be the name of a file to create. In either case, three
things can happen when an individual file is copied.
If destination does not exist, source gets copied. This is the usual case.
If destination is an existing file, an error occurs if overwrite is False. Otherwise, an attempt is made to copy source over the
existing file.
If destination is a directory, an error occurs.
Make sure either Destinationis set to a filename, not a directory, or that filepath is set to multiple files using wildcards.
BTW, if Destination is expected to remains a directory, you shouldn't test fso.FileExists(Destination).
You can use BuildPath() and GetFileName() to construct the destination filename if needed:
Public Sub SomeName()
Set fso = CreateObject("scripting.filesystemobject")
Destination = "C:\Users\test\"
Set oFolder = fso.GetFolder(Destination)
Set workboo = Workbooks.Open("C:\Users\listing.xlsx")
Set worksh = workboo.Worksheets("List_File")
For j = 1 To 10
numrows = worksh.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To numrows
icol = 2 * j - 1
filepath = worksh.Cells(i, icol).Value
filedest = fso.BuildPath(Destination,fso.GetFileName(filepath))
If Not fso.FileExists(filedest) Then
fso.CopyFile filepath, filedest
End If
Next
Next
workboo.Close
End Sub
I didn't edit much your code, but defining you variable with Dim ... should be a good idea.
As per information gathered from you, I have designed the program. I have kept source Folder and file string separately. To extract file name, I have used TRIM and MID functions.
sFile = Trim(Mid((worksh.Cells(i, icol).Text), 39, 99))
You may check the length of the Source Folder "P:\Desktop\Nouveau dossier (4)\Source\" exactly by LEN function and then add 1 to that length for start of file name. Further I have kept total number of characters tentatively 99 which you may adjust according to maximum file name length you are using. Please also ensure that source and destination folders are correct in the program and match with your physical folder paths on your computer. I have tested it on my computer and it is working fine on sample data.I have also set reference to Microsoft Scripting Runtime Library.
Sub CopyingFiles_Q37539919()
'Declaration
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Dim i As Integer, j As Integer
Dim icol As Long
Dim numrows As Long
Set workboo = Workbooks.Open("C:\Users\listing.xlsx")
Set worksh = workboo.Worksheets("List_File")
numrows = worksh.Range("A" & Rows.Count).End(xlUp).Row
Debug.Print numrows
'Change to match the source folder path.
sSFolder = "C:\mydir_s\" '
'Change to match the destination folder path.
sDFolder = "C:\Users\test\"
For j = 1 To 10
For i = 2 To numrows
icol = 2 * j - 1
sFile = Trim(Mid((worksh.Cells(i, icol).Text), 39, 99)) ' Adjust the figure 39 for start of file name and 99 for maximum length of file name
Debug.Print sFile
Debug.Print sSFolder & sFile
'Create Object for File System
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(sSFolder & sFile) Then
MsgBox "Specified File Not Found in Source Folder", vbInformation, "Not Found"
End If
'Copying If the Same File is Not Located in the Destination Folder
If Not FSO.FileExists(sDFolder & sFile) Then
FSO.CopyFile (sSFolder & sFile), sDFolder, True
MsgBox "Specified File Copied to Destination Folder Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If
Next
Next
End Sub
On seeing your code i agree with Trimax the area of problem he is pointing. Apart from that you need to make sure followings:
1. Make sure "filepath" variable is fully qualified path for the file like "d:\yourdirctoryname\yourfilename.extension"
2. Make sure file exists at source location if not the same validation you can write for "filepath" as you did for "destination"
3. if you have same extension files to be copied then you should use wildcard to copy file to the destination it will reduce system effort. For more detail follow https://msdn.microsoft.com/en-us/library/e1wf9e7w(v=vs.84).aspx for wildcard code.
I believe it will resolve the issue.

How to parse a .doc file using a word VBA

I am stuck with this word VBA and in need of some assistance.I have 160 word documents in a folder and each .doc contains atleast one phrase like 'IO:' I want to copy all the file names that starts after 'IO:' and stop copying when the cursor finds Report Output:. Here is one sample input:
`Step Name: Step 3 – GP00BMDR
Step Description:: GENISYS main batch driver which processes external transactions and internal transactions, updates masters, generates transaction records to the accounting subsystem and produces print files.
File Specification:
Input: 1. GPFTRNW – PHGP.GPFTRNW.TRN.STD.KSDS
2. GPFSCIM – PHGP.GPFSCIM.SCI.KSDS
3. GPFSCSM – PHGP.GPFSCSM.SCS.KSDS
IO: 1. GPFPDGT – PHGP.GPFPDGT.PDG.TRN.KSDS
2. GPFRTXT – PHGP.GPFRTXT.RTX.KSDS
Report Output: Nil`
So I want to copy the .doc name and the file names after IO: and stops when the cursor reaches Report Output: . Here is my script:
Sub Ftp_Step_Details()
'this macro checks for FTP in respective steps and copy and writes in a cell along with the corresponding JCL
Dim wordApplication As Word.Application
Dim wordDocument As Word.Document
Dim flag As String
Dim Folder As String, J As String, FLD As Object
Dim Objfile As Object
Dim objfso As Object
Dim intRow As String
Dim contents As String
flag = True
Dim intResult As Integer
Dim strPath As String
'the dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
End If
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\FILE-LIST\File-List.xlsx")
objExcel.Visible = True
objExcel.Workbooks.Add
objExcel.Cells(1, 1).Value = "Jcl Name"
objExcel.Cells(1, 2).Value = "File Names"
'Folder = "D:\TEST-IO" 'JCL source goes here
Set objfso = CreateObject("Scripting.FileSystemObject")
Set wordApplication = CreateObject("Word.Application")
intRow = 2
'Opening the file in READ mode
Set FLD = objfso.GetFolder(strPath)
For Each file In FLD.Files
Set Objfile = wordApplication.Documents.Open(file)
Do While Not Objfile.AtEndOfStream
contents = Objfile.ReadLine
If contents Like "*IO:" Then
flag = True
End If
If contents Like "*Report Output:*" Then
flag = False
End If
If flag = True Then
objExcel.Cells(intRow, 1).Value = file.Name
objExcel.Cells(intRow, 2).Value = contents3
intRow = intRow + 1
End If
Loop
Next
Objfile.Close
MsgBox "THANK YOU"
End Sub
Now whie testing the code i am getting TYPE MISMATCH in the step Set Objfile = wordApplication.Documents.Open(file) why is that?
Another doubt I have does Readline function works in word VBA as well?
Now whie testing the code i am getting TYPE MISMATCH in the step Set Objfile = wordApplication.Documents.Open(file) why is that?
Because File is type Scripting.File which is an Object, and the Documents.Open method expects a string.
You could try:
Documents.Open(file.Path)
Another doubt I have does Readline function works in word VBA as well?
No, I don't think so.