in the Range A1:A2 I stored the file name.
The files are stored in three different folders.
And the file name start with the search criteria in A1 but is not always match 100 %.
A1 = "test1"
But the pdf documents, which I am looking for call
"test1-e"
, but this is the right one which I need.
After finding the correct pdf in the three folders, I need to copy it to the Source Path.
My approach looks like this:
Sub copyFile()
Dim objFSO As Object, rng As Range
Dim strFileToCopy, strOldPath As String, strOldPath2 As String, strOldPath3 As String, strNewPath As String
strOldPath = "" 'Verzeichnis Nr. 1 in dem die Datei liegt
strOldPath2 = "" 'Verzeichnis Nr. 2 in dem die Datei liegt
strOldPath3 = "" 'Verzeichnis Nr. 3 in dem die Datei liegt
strNewPath = ""
With ActiveSheet
For Each rng In Range("A1:A2")
'strFileToCopy = .Range("A2") 'Zelle mit dem Namen
If strFileToCopy Like rng Then
strFileToCopy = rng
strFileToCopy = strFileToCopy & ".pdf" 'Suffix anhängen
Set objFSO = CreateObject("Scripting.FileSystemObject")
OldPath = objFSO.BuildPath(strOldPath, strFileToCopy)
If objFSO.FileExists(OldPath) Then
objFSO.copyFile OldPath, objFSO.BuildPath(strNewPath, strFileToCopy)
End If
End If
Next
'If Dir(strOldPath & strFileToCopy, vbNormal) <> "" Then
' Set objFSO = CreateObject("Scripting.FileSystemObject")
'objFSO.copyFile strOldPath & strFileToCopy, strNewPath & strFileToCopy
'End If
End With
Set objFSO = Nothing
End Sub
But my problem is, how can search in different folders and how can I search with "Like-Expression", because my solution didn't work out. Thanks a lot for the support.
Something along these lines I would use. This returns an array of files.
Function ReturnFiles(strSourceFolder As String, strSearch As String) As Scripting.File()
Dim a() As File
Dim fso As Scripting.FileSystemObject
Dim f As Scripting.Folder
Dim fl As Scripting.File
On Error GoTo eHandle
Set fso = New Scripting.FileSystemObject
If fso.FolderExists(strSourceFolder) Then
Set f = fso.GetFolder(strSourceFolder)
For Each fl In f.Files
If Left(fl.Name, Len(strSearch)) = strSearch Then ' Or instr here for example
Set a(UBound(a)) = fl
ReDim Preserve a(UBound(a) + 1)
End If
Next fl
Else
End If
ReturnFiles = a
HouseKeeping:
Set fl = Nothing
Set f = Nothing
Set fso = Nothing
Erase a
Exit Function
eHandle:
If Err.Number = 9 Then
ReDim a(0)
Resume
Else
GoTo HouseKeeping
End If
End Function
Related
Below is code that should let me select a folder, then find and replace periods in the word documents within the folder and replace them with a space.
I got the code to work, my computer crashed, and now I don't remember what I did, and I'm getting a 'user-defined type' error.
I'm not quite sure how to fix this.
I'm also trying to get this to work from excel (not just from word) so any help there would be appreciated.
Sub Step_1() 'select folder with raw files to clean up
Dim wordApp As Word.Application
Dim objDocument As Word.Document
Dim intResult As Integer
Dim strPath As String
Dim arrFiles() As String
Dim i As Integer
'box will open where user can pick folder with raw files
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancelled the dialog
If intResult <> 0 Then
'display folder search box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
arrFiles() = GetAllFilePaths(strPath)
For i = LBound(arrFiles) To UBound(arrFiles)
Call ModifyFile(arrFiles(i))
Next i
End If
End Sub
Private Sub ModifyFile(ByVal strPath As String)
Dim wordApp As Word.Application
Dim objDocument As Word.Document
Set objDocument = wordApp.Documents.Open(strPath)
objDocument.Activate
For Each objDocument In strPath
With Selection.Find
.Text = "."
.Replacement.Text = " "
.Find.Execute Replace:=wdReplaceAll
'there's a much longer list of things to replace
End With
objDocument.Close (True)
Next
Next
End Sub
Private Function GetAllFilePaths(ByVal strPath As String) _
As String()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim arrOutput() As String
ReDim arrOutput(1 To 1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strPath)
i = 1
'loops through each file in the directory and
'prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve arrOutput(1 To i)
'print file path
arrOutput(i) = objFile.Path
i = i + 1
Next objFile
GetAllFilePaths = arrOutput
End Function
Cleaned up:
Sub ProcessFiles()
Dim wordApp As Word.Application
Dim wdDoc As Word.document
Dim strPath As String, allfiles As Collection, fPath
strPath = GetFolderPath()
If Len(strPath) = 0 Then Exit Sub
Set allfiles = GetAllFiles(strPath, "*.doc*")
If allfiles.Count = 0 Then
MsgBox "No Word files found"
Exit Sub
End If
Set wordApp = New Word.Application
wordApp.Visible = True
'loop over found files
For Each fPath In allfiles
Debug.Print "Processing " & fPath
Set wdDoc = wordApp.documents.Open(fPath)
ReplaceDocContent wdDoc, ".", " "
ReplaceDocContent wdDoc, ",", " "
ReplaceDocContent wdDoc, "~", " "
'etc.....
wdDoc.Close True 'close and save changes
Next fPath
MsgBox "done"
End Sub
'replace text in a Word document with some other text
Private Sub ReplaceDocContent(doc As Word.document, findWhat, replaceWith)
With doc.Range.Find
.Text = findWhat
.Replacement.Text = replaceWith
.Execute Replace:=wdReplaceAll
End With
End Sub
'collect all files under folder `strPath` which match `pattern`
Private Function GetAllFiles(ByVal strPath As String, pattern As String) As Collection
Dim objFile As Object, col As New Collection
'Create an instance of the FileSystemObject and list all files
For Each objFile In CreateObject("Scripting.FileSystemObject").GetFolder(strPath).Files
If objFile.Path Like pattern Then col.Add objFile.Path
Next objFile
Set GetAllFiles = col
End Function
'return selected folder path or empty string
Function GetFolderPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> 0 Then GetFolderPath = .SelectedItems(1)
End With
End Function
I have below code to check if a folder exist on the predefined directory.
Option Explicit
Public xStatus As String
Sub Status()
Application.ScreenUpdating = False
Dim fso As Object
Dim folder As Object
Dim subfolders As Object
Dim subfolder1 As Object
Dim Rg As Range
Dim xCell As Range
Dim xTxt As String
xTxt = ActiveWindow.RangeSelection.Address
Set Rg = Application.InputBox("Please select city/cities to check production status!!! ", "Lmtools", xTxt, , , , , 8)
If Rg Is Nothing Then
MsgBox ("No cities selected!!!")
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("D:\")
Set subfolders = folder.subfolders
For Each xCell In Rg
If xCell.Value <> "" Then
For Each subfolder1 In subfolders
xStatus = subfolder1.path
If xStatus Like "*?\" & xCell.Value Then
Cells(xCell.Row, xCell.Column + 1).Value = "Completed"
Cells(xCell.Row, xCell.Column + 2).Value = xStatus
GoTo nextiteration
Else
Cells(xCell.Row, xCell.Column + 1).Value = "Ongoing"
End If
Next
End If
nextiteration:
Next
Application.ScreenUpdating = True
End Sub
It works fine but only checks the sub-folders of "D:\" and not beyond that.
My folder could be present anywhere (either inside the sub-folders or their sub-folders or alongside "D:\"'s sub-folders.
my concern is how to iterate through all the folders.
I creted this a while back. Basically i used this to rename file in folders and sub-folders,
Option Explicit
Sub VersionRename()
Dim SelectedFolder As FileDialog
Dim T_Str As String
Dim FSO As Object
Dim RenamingFolder As Object, SubFolder As Object
Dim T_Name As String
Set SelectedFolder = Application.FileDialog(msoFileDialogFolderPicker)
SelectedFolder.Title = "Select folder:"
SelectedFolder.ButtonName = "Select Folder"
If SelectedFolder.Show = -1 Then
T_Str = SelectedFolder.SelectedItems(1)
Else
'MsgBox "Cancelled by user.", vbInformation
Set SelectedFolder = Nothing
Exit Sub
End If
Set SelectedFolder = Nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
Set RenamingFolder = FSO.GetFolder(T_Str)
File_Renamer RenamingFolder
For Each SubFolder In RenamingFolder.SubFolders
File_Renamer SubFolder
Next
Set SubFolder = Nothing
Set RenamingFolder = Nothing
Set FSO = Nothing
MsgBox "Process completed!", vbInformation, Title:="Renaming Files"
End Sub
Private Sub File_Renamer(Folder As Object)
Dim File As Object
Dim T_Str As String
Dim T_Name As String
Dim PreVersionID As Variant
Dim NextVersionID As Variant
Dim StringReplace As String
PreVersionID = Application.InputBox("Input 1 if no version number otherwise input existing version number:", Type:=1)
If PreVersionID = False Then Exit Sub
NextVersionID = Application.InputBox("Input your next version number:", Type:=1)
If NextVersionID = False Then Exit Sub
T_Str = Format("_V" & NextVersionID)
For Each File In Folder.Files
T_Name = File.Name
'Debug.Print T_Name
If NextVersionID > 1 Then
StringReplace = Replace(T_Name, "_V" & PreVersionID, "", 1, 3)
'Debug.Print StringReplace
File.Name = Left(StringReplace, InStrRev(StringReplace, ".") - 1) & T_Str & Right(StringReplace, Len(StringReplace) - (InStrRev(StringReplace, ".") - 1))
Else
File.Name = Left(T_Name, InStrRev(T_Name, ".") - 1) & T_Str & Right(T_Name, Len(T_Name) - (InStrRev(T_Name, ".") - 1))
End If
Next
End Sub
I have complied some data and I want to move one text file at one time to another folder using (*.txt). Is it possible?
I would like only that function with (*.txt) because it is complicated for me to use any other function and would suit my code best.
What I am trying to do is loop the Move.File function to 7 text files only in which one file only move at one time then the next file moves and so on. While moving one text file, another Naming function to extract the next text name. Hopefully that makes sense.
Dim FSO As Object
Dim SourceFileName As String, DestinFileName As String
k = 0
Do While k < 19
ActiveCell.Offset(-2, k).MergeArea.ClearContents
ActiveCell.Offset(-2, k).Value = Dir(FolderName & "*.txt*")
Set FSO = CreateObject("Scripting.Filesystemobject")
SourceFileName = "Y:\Engineering\*.txt"
DestinFileName = "Y:\Engineering\Completed\"
FSO.MoveFile Source:=SourceFileName, Destination:=DestinFileName
k = k + 3
Loop
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
fnd = ".txt"
rplc = ""
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, replacement:=rplc
Next sht
End Sub
What it does when I use this code it moves all the text files at once to that folder. So when I loop to name headings to text files it gives an error.
If I understood your goal correctly then may try (tested to successfully perform according to my understanding of the goal)
Sub test()
Dim FSO As Object
Dim SourceFileName As String, DestinFileName As String
Dim FolderName As String
FolderName = "Y:\Engineering\"
FolderName = "C:\users\user\Desktop\Folder1\" 'modify to your requirement
Set FSO = CreateObject("Scripting.Filesystemobject")
k = 0
SourceFileName = Dir(FolderName & "*.txt")
Do While k < 19 And SourceFileName <> ""
Debug.Print SourceFileName
ActiveCell.Offset(-2, k).MergeArea.ClearContents
ActiveCell.Offset(-2, k).Value = SourceFileName
DestinFileName = FolderName & "Completed\" & SourceFileName
SourceFileName = FolderName & SourceFileName
FSO.MoveFile Source:=SourceFileName, Destination:=DestinFileName
k = k + 3 ' Why K is being incremented by 3? It will only move seven files
SourceFileName = Dir
Loop
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
fnd = ".txt"
rplc = ""
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, replacement:=rplc
Next sht
End Sub
This question already has answers here:
Get list of sub-directories in VBA
(5 answers)
Closed 8 years ago.
I have searched the forum, and found similar questions that got answered, but I am really a beginner in VBA.
I want to copy the name, path, and last modified date information to an Excel spreadsheet.
The code in the following two threads can help me add the name, path and last modified date information of a certain folder to Spreadsheet. The only thing I need to do is to add a loop that searches files under subfolders. I tried to, but it was not successful.
Can anyone help me add a loop of the files in the subfolders based on the code below?
Getting file last modified date (explorer value not cmd value)
Excel VBA using FileSystemObject to list file last date modified
Sub ListFilesinFolderNew()
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim fsoFol As Scripting.Folder
SourceFolderName = "C:\Users\lc\Downloads"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("file", "path", "Date Last Modified")
i = 2
For Each fsoFol In SourceFolder.SubFolders
For Each FileItem In fsoFol.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Next fsoFol
Set FSO = Nothing
End Sub
Thank you.
In order to list all files in a folder and its subfolders, i would suggest seperating the listing logic into a seperate Sub and calling it recursively.
Something like this
Sub ListFilesinFolderNew()
Dim FSO As Scripting.FileSystemObject
Dim ws As Worksheet
Dim cl As Range
Dim SourceFolderName As String
SourceFolderName = "C:\Users\lc\Downloads"
Set FSO = New Scripting.FileSystemObject
Set ws = ActiveSheet '<-- adjust to suit your needs
ws.Range("A1:C1") = Array("file", "path", "Date Last Modified")
Set cl = ws.Cells(2, 1)
ListFolders cl, FSO.GetFolder(SourceFolderName)
Set FSO = 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
End Sub
Alternate method using Dir
Sub ListFilesinFolderNew2()
Dim Path As String
Dim fl As String
Dim ws As Worksheet
Dim cl As Range
Set ws = ActiveSheet
Path = "C:\Users\lc\Downloads"
ws.Range("A1:C1") = Array("file", "path", "Date Last Modified")
Set cl = ws.Cells(2, 1)
ListFolder cl, Path, "*.*"
End Sub
Sub ListFolder(rng As Range, Path As String, Patt As String)
Dim fl As String
Dim sf As Collection
Dim v As Variant
If Right$(Path, 1) <> "\" Then Path = Path & "\"
fl = Dir(Path & Patt)
Do While fl <> vbNullString
rng.Cells(1, 1) = fl
rng.Cells(1, 2) = Path
rng.Cells(1, 3) = FileDateTime(Path & fl)
Set rng = rng.Offset(1, 0)
fl = Dir()
Loop
Set sf = New Collection
fl = Dir(Path, vbDirectory)
Do While fl <> vbNullString
If fl <> "." And fl <> ".." Then
If (GetAttr(Path & fl) And vbDirectory) <> 0 Then
sf.Add Path & fl
End If
End If
fl = Dir()
Loop
For Each v In sf
rng.Cells(1, 2) = Path
Set rng = rng.Offset(1, 0)
ListFolder rng, CStr(v), Patt
Next
End Sub
Ok try this to get the files on the folder and sub folders:
Dim donewithparent As Boolean
For Each fsoFol In SourceFolder.SubFolders
If Not donewithparent Then
For Each FileItem In fsoFol.ParentFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next
End If
donewithparent = True
For Each FileItem In fsoFOL.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Next fsoFol
Or you can do a separate loop for it before you loop on the subfolders.
Just utilize the available properties like ParentFolder.
To check if there are still sub folders undet it, you can use:
If fsoFol.Subfolders.Count > 0 Then
'~~> add another loop here
End If
Not really ideal but should work. HTH.
So I'm pretty new to VBA.
The below code works fine in 2007 for listing all of the PDF files in a particular folder. However, this code doesn't seem to work when I try it in excel 2010 (it throws an error on Set fold = fso.GetFolder(folderPath))
Any Ideas What I'm doing wrong?
I do have Scripting Runtime checked. My code is below:
Sub List_files()
Dim fso As FileSystemObject
Dim fold As Folder
Dim f As File
Dim folderPath As String
Dim i As Integer
folderPath = "S:\Academic Affairs\Academic Operations Reporting\CV's"
Set fso = New FileSystemObject
Set fold = fso.GetFolder(folderPath)
i = 2
For Each f In fold.Files
If LCase(Right(f.Name, 3)) = "pdf" Then
Range("A" & i).Value = f.Name
i = i + 1
End If
Next
End Sub
I think you need a "\" on the folderPath variable... so that it is
folderPath = "S:\Academic Affairs\Academic Operations Reporting\CV's\"
If that doesn't fix it, post the error you're getting.
Here is a procedure that I use for listing files:
Function GetFileList(pDirPath As String) As Variant
On Error GoTo GetFileList_err
' Local constants / variables
Const cProcName = "GetFileList"
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim c As Double ' upper bound for file name array
Dim i As Double ' iterator for file name array
Dim vFileList() As String ' array for file names
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(pDirPath)
c = objFolder.Files.Count
i = 0
ReDim vFileList(1 To c) ' set bounds on file array now we know count
'Loop through the Files collection
For Each objFile In objFolder.Files
'Debug.Print objFile.Name
i = i + 1
vFileList(i) = objFile.Name
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
GetFileList = vFileList
GetFileList_exit:
Exit Function
GetFileList_err:
Debug.Print "Error in ", cProcName, " Err no: ", Err.Number, vbCrLf, "Err Description: ", Err.Description
Resume Next
End Function
Sub PrintFileList(pDirPath As String, _
Optional pPrintToSheet = False, _
Optional pStartCellAddr = "$A$1", _
Optional pCheckCondition = False, _
Optional pFileNameContains)
On Error GoTo PrintFileList_err
' Local constants / variables
Const cProcName = "PrintFileList"
Dim vFileList() As String ' array for file names
Dim i As Integer ' iterator for file name array
Dim j As Integer ' match counter
Dim c As String
vFileList = GetFileList(pDirPath)
c = pStartCellAddr
j = 0
For i = LBound(vFileList) To UBound(vFileList)
If pPrintToSheet Then
If pCheckCondition Then
' if pFileNameContains not in filename go to next iteration of loop
If InStr(1, vFileList(i), pFileNameContains, vbTextCompare) = 0 Then
GoTo EndLoop
End If
End If
Range(c).Offset(j, 0).Value = vFileList(i)
j = j + 1
End If
'Debug.Print vFileList(i)
i = i + 1
EndLoop:
Next
PrintFileList_exit:
Exit Sub
PrintFileList_err:
Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
vbCrLf, "Err Description: ", Err.Description
Resume Next
End Sub
The function is just for internal use, you call the procedure. Here is an example call (in this case using the userprofile windows environment variable as the path rather than a hard coded path):
call PrintFileList(environ("userprofile"), True, "$A$1", True, ".pdf")
Whenever things are not working as they "should" it's very productive to start with a minimal approach that works and build from there.
Try this that works in Excel 2016:
Option Explicit
Sub File_renaming2()
Dim objFSO As FileSystemObject
Dim mySource As Folder
Dim myFolder As File
Set objFSO = New FileSystemObject
Set mySource = objFSO.GetFolder("S:\Academic Affairs\Academic Operations Reporting\CV's\")
For Each myFolder In mySource.Files
Debug.Print myFolder.Name
Next myFolder
End Sub
Use this:
Set fso = New Scripting.FileSystemObject
Don't know how to explain:
But we need to make the full reference to the object type
CHANGE
"Dim mySource As Folder "
TO
"Dim mySource As Scripting.Folder" 'OR "Dim mySource As object"
Why ?
In my case the working code stopt from working
=> I added the "microsoft outlook object library" => it has a "Folder" type to
=> so nothing worked for me aftherwards