VBA opening files which have a specific keyword in them - vba

I have a folder which has a bunch of .xls files, of which only those which have the KEY Word " CITIES " are of interest to me. I need to open those files and collect some information and I am facing some issues.
Sub getTheExecSummary()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
myPath = "C:\Users\Morpheus\Documents\Projects\Files"
myExtension = "*.xls" 'How to add the keyword?'
myFile = Dir(myPath & myExtension)
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Debug.Print (myFile)
Debug.Print (wb.Name)
ActiveSheet.Range("A1").Value = wb.Name
'Get next file name
myFile = Dir
Loop
End Sub
I did write a few Debug.Print statements none of which seem to work. I want to for now print only those workbooks which have the keyword ' CITIES ' in their name.

I think that you want the Instr function.
If Instr(wb.Name, "CITIES") > 0 then .....
You might want to use "CITIES " or " CITIES " to exclude any unintentional uses of those letters, depending on how the filename is setup

Use the wildcard to identify the missing letters: *CITIES*.xls or *CITIES*.xls* if you're expecting xlsx, xlsm, etc.
Sub Test()
Dim colFiles As Collection
Dim vItem As Variant
Dim wrkBk As Workbook
Dim sPath As String
Set colFiles = New Collection
sPath = "C:\Users\Morpheus\Documents\Projects\Files\"
'you could use:
'sPath = Environ("UserProfile") & "\Documents\Projects\Files\"
EnumerateFiles sPath, "*CITIES*.xls", colFiles
For Each vItem In colFiles
Set wrkBk = Workbooks.Open(vItem)
wrkBk.Worksheets("Sheet1").Range("A1") = wrkBk.Name
Next vItem
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub

Related

VBA; how to extract all files names from a folder - without using Application.FileDialog object

As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function

Copy all excel files from one location to another

I have written the below script which creates a folder in a given location if it doesn't exist which is named after a cell in the workbook.
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Dim sFileType As String
Dim sSourcePath As String
Dim Destination As String
Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\INSURANCE\IT\FileData\Computers\DIPS\"
fldrname = Worksheets("Applications").Range("A2").Value
fldrpath = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End If
I'm now trying to copy all .xlsm files in sSourcePath to the newly created location fldrpath & \ fldrname yet all attempts fail. I'm still fairly new to VBA so any help would be appreciated.
I have heard of .copyfile but i'm not sure how to utilise this in this example.
Thank you in advance.
I do this without filesystemobject.
Sub copyfiles()
Dim source_file As String, dest_file As String
Dim source_path As String, dest_path As String
Dim i As Long, file_array As Variant
source_path = "\\INSURANCE\IT\FileData\Computers\DIPS"
dest_path = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive"
source_file = Dir(source_path & "\" & "*.xlsm")
Do Until source_file = ""
If Not IsArray(file_array) Then
ReDim file_array(0) As Variant
Else
ReDim Preserve file_array(UBound(file_array) + 1) As Variant
End If
file_array(UBound(file_array)) = source_file
source_file = Dir
Loop
'If new folder is not existed, create it.
If Dir(dest_path, 16) = "" Then MkDir dest_path '16=vbDirectory
For i = LBound(file_array) To UBound(file_array)
FileCopy source_path & "\" & file_array(i), dest_path & "\" & file_array(i)
Next i
End Sub
My take on that
Sub copyFiles()
Dim fldrname As String, fldrpath As String, sFileType As String
Dim sSourcePath As String, Destination As String
Dim fso As Object, fFolder As Object, fFile As Object
Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\SourcePath" '"\\INSURANCE\IT\FileData\Computers\DIPS\"
fldrname = "data\" 'Worksheets("Applications").Range("A2").Value
fldrpath = "\\SourcePath\Archive\" & fldrname '"\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set fFolder = fso.GetFolder(sSourcePath)
For Each fFile In fFolder.Files
'If Not (fso.FileExists(fldrpath & fFile.Name)) Then fFile.Copy fldrpath, Overwritefiles:=False
fFile.Copy fldrpath, Overwritefiles:=True
Next fFile
End Sub

How to edit multiple excel files each of which are in a different folder united in one folder

This question isn't supposed to be complicated. I have one big folder and in it it has 200 individual folders. Now each of those folders has one excel sheet in it. I want to have some code in a vba file in control folder (which is next to the 200) which can iterate over the 200 folders and change one bit of data in each excel file. I found directory stuff and folder iterations, However I can't take bit for here and there and merge them together, i need some simple help.
my code is currently: `Sub Button1_Click()
Dim wb As Workbook
Dim ws As Excel.Worksheet
Dim iIndex As Integer
Dim strPath As String
Dim strFile As String
'Get the directories
strPath = "C:\Users\generaluser\Desktop\testing main folder\"
strFile = Dir(strPath, vbDirectory)
'Loop through the dirs
Do While strFile <> ""
'Open the workbook.
strFileName = Dir(strPath & strFile & "New Microsoft Excel Worksheet.xlsm", vbDirectory)
'Open the workbook.
Set wb = Workbooks.Open(Filename:=strPath & strFile & "\" & strFileName, ReadOnly:=False)
'Loop through the sheets.
Set ws = Application.Worksheets(1)
'Do whatever
'Close the workbook
wb.Close SaveChanges:=True
'Move to the next dir.
strFile = Dir
Loop
End Sub
`
Please help #MatthewD
Since you didn't show code, it's something like this.
Dim wb As Workbook
Dim ws As Excel.Worksheet
Dim iIndex As Integer
Dim strPath As String
Dim strFile As String
'Get the directories
strPath = "c:\temp\"
strFile = Dir(strPath, vbDirectory)
'Loop through the dirs
Do While strFile <> ""
'Open the workbook.
Set wb = Workbooks.Open(filename:=strPath & strFile & "\filename.xlsx", ReadOnly:=True)
'Loop through the sheets.
For iIndex = 1 To Application.Worksheets.count
Set ws = Application.Worksheets(iIndex)
'Do whatever
Next iIndex
'Close the workbook
wb.Close SaveChanges:=False
'Move to the next dir.
strFile = Dir
Loop
If the workbook names are not known, you'll have to dir the xlsx file in the dir.
strFileName = Dir(strPath & strFile & "*.xlsx")
'Open the workbook.
Set wb = Workbooks.Open(filename:=strPath & strFile & "\" & strFileName , ReadOnly:=True)
Ok, this should be pretty easy. Simply list every file in all the folders, recursively. The script below will do that for you.
Sub ListAllFiles()
SearchForFiles "C:\Users\rshuell001\Desktop\YourFolder\", "writefilestosheet", "*.*", True, True
End Sub
Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _
Optional ByVal FileTypeToFind As String = "*.*", _
Optional ByVal SearchSubDir As Boolean = False, _
Optional ByVal FilesFirst As Boolean = False)
On Error GoTo ErrXIT
If Right(DirToSearch, 1) <> Application.PathSeparator Then _
DirToSearch = DirToSearch & Application.PathSeparator
If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind
If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _
FileTypeToFind, SearchSubDir, FilesFirst
If Not FilesFirst Then _
processFiles DirToSearch, ProcToCall, FileTypeToFind
Exit Sub
ErrXIT:
MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")"
Exit Sub
End Sub
Private Sub processFiles(ByVal DirToSearch As String, _
ByVal ProcToCall As String, _
ByVal FileTypeToFind As String)
Dim aFile As String
aFile = Dir(DirToSearch & FileTypeToFind)
Do While aFile <> ""
Application.Run ProcToCall, DirToSearch & aFile
aFile = Dir()
Loop
End Sub
Sub writeFilesToSheet(ByVal aFilename As String)
With ActiveSheet
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename
End With
End Sub
Next, as you're aware of, you'll need to access each file, using the technique above, open each, make your change, save it, and close the file. Use the technique described from the URL below, to make the changes.
http://www.rondebruin.nl/win/s3/win010.htm
You'll have to modify the script just a bit, because that looks for all files on one folder, you need Ron's script to run through the different paths you created with the first script

Create a vba code to replace all the headers, of all the word documents in a Folder and Subfolders

Sub ReplaceEntireHdr()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
AppActivate wrd.Name
'Change the directory to YOUR folder's path
fName = Dir("C:\Users\user1\Desktop\A\*.doc")
Do While (fName <> "")
With wrd
'Change the directory to YOUR folder's path
.Documents.Open ("C:\Users\user1\Desktop\A\" & fName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
.Selection.WholeStory
.Selection.Paste
.ActiveDocument.Save
.ActiveDocument.Close
End With
fName = Dir
Loop
Set wrd = Nothing
End Sub
I use this vba code to replace all the headers, of all the word documents in a folder 'A'. However if there is any subfolder in the parent folder 'A' with word documents, the vba code skips those documents. Could anyone please tell me how to include the word documents in the subfolders as well? Perhaps by making some changes in the code or any other vba code which can do the same job.
Thanks in advance.
In order to pick up the folders (directories) you need to specify the vbDirectory attribute. By default, Dir only "sees" things that match vbNormal.
Here's an example that picks up both files and sub-directories. The GetAttr function checks whether the file attribute is vbDirectory. If it's not, then it's a file.
What you can do is save the directory paths in an array, then loop that to get the files in the sub-directories.
Sub GetFilesandSubDir()
Dim sPath As String, sPattern As String
Dim sSearch As String, sFile As String
Dim sPathSub As String, sSearchSub As String
Dim aSubDirs As Variant, i As Long
sPattern = "*.*"
sPath = "C:\Test\"
sSearch = sPath & sPattern
sFile = Dir(sPath, vbNormal + vbDirectory)
aSubDirs = TestDirWithSubFolders(sPath, sPattern, sSearch, sFile)
For i = LBound(aSubDirs) To UBound(aSubDirs)
Debug.Print "Directory: " & aSubDirs(i)
sPathSub = sPath & aSubDirs(i) & "\"
sSearchSub = sPathSub & sPattern
sFile = Dir(sPathSub, vbNormal + vbDirectory)
TestDirWithSubFolders sPathSub, sPattern, sSearchSub, sFile
Next
End Sub
Function TestDirWithSubFolders(sPath As String, sPattern As String, _
sSearch As String, sFile As String) As Variant
Dim aSubDirs() As Variant, i As Long
i = 0
Do While sFile <> ""
If GetAttr(sPath & sFile) = vbDirectory Then
'Debug.Print "Directory: " & sFile
ReDim Preserve aSubDirs(i)
aSubDirs(i) = sFile
i = i + 1
Else
Debug.Print "File: " & sFile
End If
sFile = Dir
Loop
TestDirWithSubFolders = aSubDirs
End Function

VBA Excel execute macro in all subfolders, not only particular folders

I am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.
Could someone please helps to make the code works to all subfolders inside that specific folder? :)
These are my code:
Sub Execute1()
Dim monthstr As String
Dim year As String
Dim monthtext As String
Dim prevmonth As String
Dim prevmonthtext As String
year = Range("D8").Text
monthstr = Trim(Range("D9").Text)
monthtext = Trim(Range("D10").Text)
prevmonth = Trim(Range("D11").Text)
prevmonthtext = Trim(Range("D12").Text)
prevyear = Trim(Range("D13").Text)
'confirmation box before running macro//////////////////////////////////////////////////////////////////////////////////////
response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation")
If response = vbNo Then
Exit Sub
End If
'optimize macro speed///////////////////////////////////////////////////////////////////////////////////////////////////////////
Call Optimize
'finding the correct path (month)//////////////////////////////////////////////////////////////////////////////////////////
Dim myfile As String
Dim mypath As String
Dim newpath As String
mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"
myfile = Dir(mypath & "*.xlsx")
newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\"
'loop through all files in specified month//////////////////////////////////////////////////////////////////////////////////
Dim root As Workbook
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set root = Workbooks("CC Reports Center.xlsm")
Set rng = root.Worksheets("Settings").Range("H7:H14")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
rng.Copy
With ws.Range("D1")
.PasteSpecial xlPasteFormulas
End With
Next ws
Dim oldname As String
Dim newname As String
Dim wbname As String
oldname = wb.Name
wbname = Mid(oldname, 9)
newname = year & "_" & monthstr & "_" & wbname
wb.SaveAs Filename:=newpath & newname
wb.Close
Set wb = Nothing
myfile = Dir
Loop
Application.CutCopyMode = False
MsgBox "Task Complete!"
'reset macro optimization settings//////////////////////////////////////////////////////////////////////////////////////////////
Call ResetOptimize
End Sub
Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)
Sub test()
Dim root As String
root = "C:\"
Dim DC As New Collection
s = Dir(root & "*", vbDirectory)
Do Until s = ""
DC.Add s
s = Dir
Loop
For Each D In DC
Debug.Print D
On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0
Do Until s = ""
Debug.Print " " & s
s = Dir
Loop
Next
End Sub
Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.
Sub test()
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library
'Alternatively, you can add a reference to "Microsoft Scripting Runtime"
'allowing you to directly declare a filesystemobject and access related intellisense
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("C:\")
For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Name
On Error Resume Next
For Each File In SubFolder.Files
Debug.Print " " & File.Name
Next
On Error GoTo 0
Next
End Sub