I need to perform a certain task over some excel files located in subfolders (which are inside a folder). This task must exclude all those file's names that contain the letter "v".
I used file name length since the files I want to use have that length (file names with letter "V" have more than 28 characters). Here is my code.
Sub test()
Application.ScreenUpdating = False
Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
FromPath = "C:\Prueba"
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
For Each objSubFolder In objFolder.Subfolders
Dim wbk As Workbook
Dim Filename As String, File As Variant
Path = objSubFolder.Path
Filename = Dir(Path & "\*.xlsx")
For Each File In objSubFolder.Files
If Len(Filename) = 28 Then
Do something
wbk.Close True
Filename = Dir
End If
Next File
Next objSubFolder
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This code works OK until it reaches a file with "V". It just stuck in that file (do nothing, which is good) and then goes to the next subfolder, ignoring all the remaining excel files.
I need some advice on how to deal with this.
thx
Related
Recently, my organization changed the name of our One Drive causing hyperlinks in my documents linking to other files in the One Drive to become obsolete.
I am trying to create a VBA script that will ask the user for a directory, go through each word doc in the folder and subfolder (and subfolder's subfolder, etc...) and replace a section of all the hyperlinks. I am new to VBA so please, don't hesitate to point out anything.
So far, this is what I have but I can't get it to change what's in the file, let alone go through all the subfolders:
Sub getDirectory()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim FileSystem As Object
Dim HostFolder As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
'Get the directory from user
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.doc*")
End If
'convert directory into string
With xFd
.Filters.Clear
.AllowMultiSelect = False
.Show
Path = .SelectedItems(1)
End With
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(Path)
End Sub
Sub DoFolder(Folder)
'loop through folders after calling LoopThroughFiles
Dim SubFolder
Dim File
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
For Each File In Folder.Files
' Operate on each file
Call LoopThroughFiles
Next
End Sub
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim h As Hyperlink
Dim sOld As String
Dim sNew As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Do While xFileName <> ""
With Documents.Open(xFdItem & xFileName)
Application.ScreenUpdating = False
'Replace this:
sOld = "AAAA"
'With this:
sNew = "BBBB"
'Example: C:\Users\Me\AAAA\file.doc ---> C:\Users\Me\BBBB\file.doc
'replace hyperlinks
For Each h In ActiveDocument.Hyperlinks
h.Address = Replace(h.Address, sOld, sNew)
Next h
Application.ScreenUpdating = True
End With
xFileName = Dir
Loop
End Sub
I have a main Excel file and CSV data in several subfolders. I want now to load the CSVs from one subfolder, start another VBA-Script and then go to the next subfolder.
Example:
MyExcelFile.xlsm
Country 1
../Data1.csv
../Data2.csv
Country 2
../Data3.csv
../Data4.csv
Country1 Report1.csv Report2.csv Country2
Report3.csv Report4.csv
Load all CSVs from Country1, generate a Report, then go to Country2 and generate the report with this data.
Here is my VBA to load the CSVs (thanks to the Author mentioned):
Sub ImportCSVs()
'Author: Jerry Beaucaire
'Date: 8/16/2010
'Summary: Import all CSV files from a folder into separate sheets
Dim fPath As String
Dim fCSV As String
Dim wbCSV As Workbook
Dim wbMST As Workbook
Set wbMST = ThisWorkbook
fPath = (Application.ActiveWorkbook.Path & "\") 'path to CSV files, include the final \
Application.ScreenUpdating = False 'speed up macro
Application.DisplayAlerts = False 'no error messages, take default answers
fCSV = Dir(fPath & "*.txt") 'start the CSV file listing
On Error Resume Next
Do While Len(fCSV) > 0
Set wbCSV = Workbooks.Open(fPath & fCSV, xlDelimited, Delimiter:=",", Format:=6, Local:=False) 'open a CSV file
wbMST.Sheets(ActiveSheet.Name).Delete 'delete sheet if it exists
ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count) 'move new sheet into Mstr
Columns.AutoFit 'clean up display
fCSV = Dir 'ready next CSV
Loop
Application.ScreenUpdating = True
Set wbCSV = Nothing
End Sub
Can anyone explain me, how I can go to all Subfolders and hand over the "Subfolder-Name" the the ImportCSVs-CSV? I was looking for this the whole afternoon, but couldn't find an answer.
Thank you so much in advance :-)
Thank you so much for your help. I managed to do exactly what i wanted with the following code:
Sub RunAll()
Dim Fso As Object, objFolder As Object, objSubFolder As Object, tempFolder
As Object
Dim FromPath As String
Dim fpath As String
Dim FileInFolder As Object
Dim ToPath As String
Dim temporaryFolder As String
temporaryFolder = "Temp"
fpath = (Application.ActiveWorkbook.Path & "\")
FromPath = fpath
ToPath = fpath & temporaryFolder & "\"
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
'clean Masterfolder first
Set tempFolder = Fso.GetFolder(ToPath)
'loop through each subfolders
For Each objSubFolder In objFolder.subfolders
For Each File In tempFolder.Files
File.Delete
Next File
For Each FileInFolder In objSubFolder.Files
If FileInFolder.Name Like "*REPORT*.txt" Then 'criteria
FileInFolder.Copy ToPath
End If
Next FileInFolder
'Check if folder is empty
If Dir(ToPath & "*.*") = "" Then
Else
Call ImportCSVs
Call ImportData
Call PrintPDF
End If
Next objSubFolder
Call CloseFile
End Sub
Creating objects is the concept here. My way is loop through all CSV files in the target folder(includes its subfolders) , and then import those CSV meet my criteria into a new temp folder.
Then you can use your current code to load all CSV to mastersheet, rename and control the temp folder whatever. Hope this helps.
Dim Fso As Object, objFolder As Object, objSubFolder As Object, tempFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
Dim ToPath As String
ToPath = "V:\MasterFolder\"
FromPath = "V:\TargetFolder\"
Set Fso = CreateObject("Scripting.filesystemobject")
'clean Masterfolder first
Set tempFolder = Fso.GetFolder(ToPath)
For Each File In tempFolder.Files
File.Delete
Next File
'loop through each subfolders
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
If FileInFolder.Name Like "*DATA*" Then 'criteria
FileInFolder.Copy ToPath
End If
Next FileInFolder
Next objSubFolder
This is what I have so far, might be good might not haha!
I have been trying to save a word document to about 400+ folders without having to go through them all, can this be done through VB Macros? I got it working to just save it to the directory, but I cannot save it to all the Subfolders.
Dim FileSystem As Object
Dim HostFolder As String
Sub DoFolder(folder)
HostFolder = ("H:\test2")
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
Dim SubFolder
For Each SubFolder In folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In folder.Files
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' Operate on each file
ActiveDocument.Save
Next
End Sub
I recommended reading: Chip Pearson -Recursion And The FileSystemObject
Make a recursive subroutine to iterate over all the subfolders (and their subfolders) in the root directory.
getAllSubfolderPaths: returns an array that lists all the sub folders in a folder.
Function getAllSubfolderPaths(FolderPath As String, Optional FSO As Object, Optional List As Object)
Dim fld As Object
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.Filesystemobject")
Set List = CreateObject("SYstem.Collections.ArrayList")
End If
List.Add FolderPath
For Each fld In FSO.GetFolder(FolderPath).SubFolders
getAllSubfolderPaths fld.Path, FSO, List
Next
getAllSubfolderPaths = List.ToArray
End Function
Test
Sub Test()
Const RootFolder As String = "C:\Users\Owner\Pictures"
Const SourcePath As String = "C:\Users\Owner\Documents\Youcam"
Const SourceFileName As String = "Capture.PNG"
Dim fld As Variant, FolderArray As Variant
Dim Destination As String, Source As String
FolderArray = getAllSubfolderPaths(RootFolder)
For Each fld In FolderArray
Destination = fld & "\" & SourceFileName
Source = SourcePath & "\" & SourceFileName
'Delete old copy of file
If Destination <> Source And Len(Dir(Destination)) Then Kill Destination
VBA.FileCopy Source:=Source, Destination:=Destination
Next
End Sub
Gotta love auditing requirements... You're basically on the right path, but you really only need one FileSystemObject. About the only errors I see are that you need the .Path of the folder here...
For Each SubFolder In folder.SubFolders
DoFolder SubFolder.Path '<---Here.
Next
...and you don't need to loop through all the files here (you may be overthinking this one a bit):
For Each File In folder.Files
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' Operate on each file
ActiveDocument.Save
Next
Also, I'd suggest using early binding instead of late binding (although the example below can easily be switched). I'd do something a bit more like this:
Private Sub SaveDocToAllSubfolders(targetPath As String, doc As Document, _
Optional root As Boolean = False)
With New Scripting.FileSystemObject
Dim current As Scripting.folder
Set current = .GetFolder(targetPath)
If Not root Then
doc.SaveAs .BuildPath(targetPath, doc.Name)
End If
Dim subDir As Scripting.folder
For Each subDir In current.SubFolders
SaveDocToAllSubfolders subDir.Path, doc
Next
End With
End Sub
The root flag is just whether or not to save a copy in the host folder. Call it like this:
SaveDocToAllSubfolders "H:\test2", ActiveDocument, True
can you help me?
i want a macro vba that search for a SPECIFIC subfolder for example (Xfolder) between all the folders and subfolders that exist and move their files.
P:\Desktop\Folder1\subfolder\SUBFOLDER1\Xfolder
I'm using the VBA Scripting Runtime objects
Set oSourceFolder = fso.GetFolder(source)
If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
For Each oFile In oFolder.Files
If Dir(destinationFolder,16) = "" Then
fso.MoveFile oFile.Path, destinationFolder
End If
Next oFile
fso.DeleteFolder oFolder.Path
Next oFolder
Here's a solution:
Dim fsoFileSystem As New FileSystemObject
Dim foFolder As Folder, foSubFolder As Folder
Dim fFile As File
Dim strStartFolder As String, strMoveFolder As String, strTargetFolder As String
strStartFolder = "\\A\B\C"
strMoveFolder = "SearchFolder"
strTargetFolder = "\\B\D\E"
Set foFolder = fsoFileSystem.GetFolder(strStartFolder)
For Each foSubFolder In foFolder.SubFolders
If foSubFolder.Name = strMoveFolder Then
For Each fFile In foSubFolder.Files
fsoFileSystem.MoveFile fFile, strTargetFolder & "\"
Next
End If
Next
strStartFolder is the folder to Screen for subfolders.
strMoveFolder is the name of the Folder to look for.
strTargetFolder is the Folder to where all the strMoveFolder's files shall be moved.
To found some folder use something like this
Sub findFolder()
Dim searchFolderName As String
searchFolderName = "somePath"
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
doFolder FileSystem.getFolder(searchFolderName)
End Sub
Sub doFolder(Folder)
Dim subFolder
On Error Resume Next
For Each subFolder In Folder.subfolders
If Split(subFolder, "\")(UBound(Split(subFolder, "\"))) = "testFolder" Then
MsgBox "gotcha"
End
End If
doFolder subFolder
Next subFolder
End Sub
And then you can do whatever with that folder and its content. So with i little use of google (one maybe two words) you can achieve what you wana
Ok, I have a macro in excel which is working perfectly.
Sub FindOpenFiles()
Dim FSO As Scripting.FileSystemObject, folder As Scripting.folder, file As Scripting.file, wb As Workbook, sh As Worksheet
Dim directory As String
directory = "O:\test\1"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder(directory)
For Each file In folder.Files
If Mid(file.Name, InStrRev(file.Name, ".") + 1) = "xls" Then
Workbooks.Open directory & Application.PathSeparator & file.Name
Set wb = Workbooks("Equipment Further Documentation List.xls")
For Each sh In Workbooks("1.xls").Worksheets
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
Next sh
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.CheckCompatibility = False
End If
Next file
End Sub
I want to modify it so I could read in file path from a text file run the macro and change the file path to another one listed in the text file and so on. As soon as the text file reaches EOF, stop the macro.
How should I change the code to make it happen.
directory = "O:\test\1"
The file paths in the .txt file are separated by return.
Thanks.
Adapt as you see fit but you should get the idea!
Const ForReading = 1
Set oFSO = New FileSystemObject
Dim txtStream As textStream
Set txtStream = oFSO.OpenTextFile("C:\....\PathtoFiles.txt", ForReading)
Do Until txtStream.AtEndOfStream
strNextLine = txtStream.ReadLine
If strNextLine <> "" Then
' Do something?
End If
Loop
txtStream.Close
The full answer is :
Sub FindOpenFiles()
Const ForReading = 1
Set oFSO = New FileSystemObject
Dim txtStream As TextStream
Dim FSO As Scripting.FileSystemObject, folder As Scripting.folder, file As Scripting.file, wb As Workbook, sh As Worksheet
Dim directory As String
Set txtStream = oFSO.OpenTextFile("C:\Users\GrzegoP\Desktop\Project\test\paths.txt", ForReading)
Do Until txtStream.AtEndOfStream
strNextLine = txtStream.ReadLine
If strNextLine <> "" Then
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder(strNextLine)
For Each file In folder.Files
If Mid(file.Name, InStrRev(file.Name, ".") + 1) = "xls" Then
Workbooks.Open directory & Application.PathSeparator & file.Name
Set wb = Workbooks("Equipment Further Documentation List.xls")
For Each sh In Workbooks("1.xls").Worksheets
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
Next sh
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.CheckCompatibility = False
End If
End If
Next file
Loop
txtStream.Close
End Sub