Related
This is driving me mad: I have a sub and a function in a powerpoint vba.
The sub starts by allowing me to select a dir. The function, called from the sub, finds a file in the dir. I want it as a function outside of the sub, as I will need to use it multiple times.
The sub is still under development, so doesn't do much, but works. The function works too if I give it something to do - like open the found file (ie uncomment that line in my code below) - but I can't for the life of me get it to return the filePath to the sub. Please help!
The sub:
Sub ManagementSummaryMerge()
Dim folderPath As String
'select dir
Dim FldrPicker As FileDialog
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
folderPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
folderPath = folderPath
If folderPath = "" Then GoTo EndOfSub
'set _Main <= string I want to look for
Dim v As String
v = "_Main"
Dim fullFilePathIWantToSet As String
'set value of fullFilePathIWantToSet from findFile function
fullFilePathIWantToSet = findFile(folderPath, v)
'when I test, this MsgBox appears, but blank
MsgBox fullFilePathIWantToSet
'If I can get this working properly, I want to be able to do something like this:
'objFSO.CopyFile fullFilePathIWantToSet, duplicateFilePath
'Presentations.Open (duplicateFilePath)
'numSlides = ActivePresentation.Slides.Count
'etc
EndOfSub:
'let the sub end
End Sub
The function:
Function findFile(ByRef folderPath As String, ByVal v As String) As String
Dim fileName As String
Dim fullFilePath As String
Dim duplicateFilePath As String
Dim numFolders As Long
Dim numSlides As Integer
Dim folders() As String
Dim i As Long
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
ileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
duplicateFilePath = folderPath & "duplicate " & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
'if true, the it matches the string we are looking for
If InStr(10, fullFilePath, v) > 0 Then
'if true, then it isn't in a dir called P/previous, which I want to avoid
If InStr(1, fullFilePath, "evious") < 1 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set f = objFSO.GetFile(fullFilePath)
'If true, then it isn't one of those funny duplicate files that microsoft makes, that has the ~ at the beginning of the file name
If f.Size > 5000 Then GoTo ReturnSettings
' if we're here then we have found the one single file that we want! Go ahead and do our thing
findFile = fullFilePath
Exit Function
End If
End If
End If
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
findFile folders(i), v
Next i
End Function
I'm a total VBA noob, so have just pva glued this together from what I can find online. Is it not working because of the findFile loop returning an array of one instead of a string? I thought the 'Exit Function' call would do away with that issue.
Please excuse the recursive if statements - the people that I am doing this for don't have a totally standard way of storing their ppts, but this hones down on the ppt I want. When the sub is complete, it will itself loop through 130 sub dirs of the selected dir, and within each of those sub dirs it will grab various slides from six different ppts and merge them into one, ie consolidate data from 780 ppts into 130 - something I definitely want to automate!
This is my first question posted on stack Overflow, so I hope I have posed it clearly and correctly. I have searched extensively for a solution to this. I hope the solution pops out to you! Many thanks in advance.
This is a classic case of needing to use Option Explicit.
You have a missing f from filename and this goes unchecked as a variable ilename not filename.
You should put Option Explicit at the top of every module and declare all your variables. There is also a missing label for a GoTo statement which I have added.
Note: You are doing a full string case sensitive match on the file name within the selected folder.
Option Explicit
Sub ManagementSummaryMerge()
Dim folderPath As String, FldrPicker As FileDialog, pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
folderPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
folderPath = folderPath
If folderPath = "" Then GoTo EndOfSub
'set _Main <= string I want to look for
Dim v As String
v = "_Main"
Dim fullFilePathIWantToSet As String
'set value of fullFilePathIWantToSet from findFile function
fullFilePathIWantToSet = findFile(folderPath, v)
'when I test, this MsgBox appears, but blank
MsgBox fullFilePathIWantToSet
'If I can get this working properly, I want to be able to do something like this:
'objFSO.CopyFile fullFilePathIWantToSet, duplicateFilePath
'Presentations.Open (duplicateFilePath)
'numSlides = ActivePresentation.Slides.Count
'etc
EndOfSub:
'let the sub end
End Sub
Function findFile(ByRef folderPath As String, ByVal v As String) As String
Dim fileName As String
Dim fullFilePath As String
Dim duplicateFilePath As String
Dim numFolders As Long
Dim numSlides As Integer
Dim folders() As String, i As Long
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
duplicateFilePath = folderPath & "duplicate " & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
'if true, the it matches the string we are looking for
If InStr(10, fullFilePath, v) > 0 Then
'if true, then it isn't in a dir called P/previous, which I want to avoid
If InStr(1, fullFilePath, "evious") < 1 Then
Dim objFSO As Object, f As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set f = objFSO.GetFile(fullFilePath)
'If true, then it isn't one of those funny duplicate files that microsoft makes, that has the ~ at the beginning of the file name
If f.Size > 5000 Then GoTo ReturnSettings
' if we're here then we have found the one single file that we want! Go ahead and do our thing
findFile = fullFilePath
Exit Function
End If
End If
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
findFile folders(i), v
Next i
Exit Function
ReturnSettings:
End Function
OK, I have a solution to this. It's not totally elegant, because it relies on globally set variables, but it works and is good enough for me:
' show if a mistake is made
Option Explicit
' globally set the var we want to return to the sub from the function
Public foundFilePath As String
Sub FindIt()
Dim colFiles As New Collection, vFile As Variant, mypath As String
FldrPicker As FileDialog, fileToFind As String, pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
mypath = .SelectedItems(1) & "\"
End With
NextCode:
mypath = mypath
If mypath = "" Then GoTo EndOf
'
' find file
'
fileToFind = "*your_string_here*"
'calls to function RecursiveDir, which sets first matching file as foundFilePath
Call RecursiveDir(colFiles, mypath, fileToFind, True)
' do what you want with foundFilePath
MsgBox "Path of file found: " & foundFilePath
'
'find second file
'
fileToFind = "*your_second_string_here*"
Call RecursiveDir(colFiles, mypath, fileToFind, True)
MsgBox "Second file path: " & foundFilePath
EndOf:
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String, fullFilePath As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
strFileSpec = Replace(strFileSpec, "*", "")
If InStr(strTemp, strFileSpec) > 0 Then
foundFilePath = strFolder & strTemp
Exit Function
End If
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
That works. What was a better solution for me is the below. It uses separate subs / functions to do the following: pick a folder ; loop through first-child folders ; recursively search for a file, using a partial file name, in all folders and subfolders ; do something with the found file/s (plural if the search function is called on multiple strings).
It's not necessary to separate out like this, but I find it easier for separation of concerns and keeping things simple.
Sub 1: Root folder picker. Passes selected folder onto sub 2
Option Explicit
Public foundFilePath As String
Sub StartSub()
' selects the parent folder and passes it to LoopSuppliers
Dim masterPath As String, FldrPicker As FileDialog, pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
pptApp.Visible = True
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
masterPath = .SelectedItems(1) & "\"
End With
NextCode:
masterPath = masterPath
If masterPath = "" Then GoTo EndOf
Call LoopSuppliers(masterPath) ' goes to masterFolder in LoopSuppliers sub
EndOf:
End Sub
Sub two: simply loops through the parent folder and passes the path of each first-child sub folder to function three to do something with it. Adapted from here.
Private Sub LoopSuppliers(masterFolder As String)
Dim objFSO As Object, objFolder As Object, objSupplierFolder As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(masterFolder)
For Each objSupplierFolder In objFolder.SubFolders
'objSupplierFolder.path objSubFolder.Name <- object keys I can grab
Call ManipulateFiles(objSupplierFolder.path)
Next objSupplierFolder
End Sub
Function 1: Grabs file paths for doing something with
Private Function ManipulateFiles(ByRef FolderPath As String)
Dim file1 As String, file2 As String, file3 As String
' each of these calls find a file anywhere in a suppliers subfolders, using the second param as a search string, and then holds it as a new var
Call FindSupplierFile(FolderPath, "search_string1")
file1 = foundFilePath
Call FindSupplierFile(FolderPath, "search_string2")
file2 = foundFilePath
Call FindSupplierFile(FolderPath, "search_string3")
file3 = foundFilePath
'
' do something with the files!
'
End Function
Function 2: This is the function that takes a dir, a search string, and then loops through all the dirs folders and sub folders until it gets a match. I've included extra filtering, to show how I further narrowed down the files that could be returned to function 1.
Private Function FindSupplierFile(ByRef FolderPath As String, ByVal v As String) As String
Dim FileName As String, fullFilePath As String, numFolders As Long, Folders() As String, i As Long
Dim objFSO As Object, f As Object
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
FileName = Dir(FolderPath & "*.*", vbDirectory)
While Len(FileName) <> 0
If Left(FileName, 1) <> "." Then
fullFilePath = FolderPath & FileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve Folders(0 To numFolders) As String
Folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
'
' my filters
'
If InStr(1, fullFilePath, "evious") < 1 Then ' filter out files in folders called "_p/Previous"
If InStr(10, fullFilePath, v) > 0 Then ' match for our search string 'v'
Set objFSO = CreateObject("Scripting.FileSystemObject") ''
Set f = objFSO.GetFile(fullFilePath) '' use these three code lines to check that the file is more that 5kb - ie not a tiny ~ file
''
If f.Size > 5000 Then ''
foundFilePath = fullFilePath ' if we get in here we have the file that we want
Exit Function ' as we have found the file we want we can exit the function (which means we carry on with ManipulateFiles)
End If ' end f.size
End If ' end InStr v if
End If ' end InStr evious if
'
' end of my filters
'
End If ' end get attr if else
End If ' end left if
FileName = Dir()
Wend ' while len <> 0
For i = 0 To numFolders - 1
FindSupplierFile Folders(i), v
Next i
End Function
I am facing issues with VBA's looping through a list of files in a directory.
I need to loop through files which only have the word CITIES in the file name. But some times some files with the word CITIES might have a corresponding FINANCE file and hence I have to loop through the Folder again to find the finance file and extract information from it. I have written a funtion to get the file name if it exists and the biggest issue is the myFile = Dir which doesn't work as i hoped it would. I have the code which is here.
Sub getTheExecSummary()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
myPath = "C:\Users\MORPHEUS\Documents\Projects\"
myExtension = "*CITIES*.xls"
myFile = Dir(myPath & myExtension)
Debug.Print myFile
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Dim prntStr As String
prntStr = wb.Worksheets("Sheet1").Cells(1, 1) & " (n= " _
& wb.Worksheets("Sheet2").Cells(12, 3) & ")"
Dim LookUpStr As String
LookUpStr = wb.Name
replaceStr = Left(LookUpStr, 10)
LookUpStr = Replace(LookUpStr, replaceStr, "")
Dim DoesTheFIleexist As String
DoesTheFIleexist = fileLoation(myPath, LookUpStr)
If (Len(DoesTheFIleexist) > 0) Then
Debug.Print (DoesTheFIleexist)
End If
Workbooks("ExecutiveSummary.xlsm").Sheets("Sheet1").Range("A1").Value = myFile
wb.Close SaveChanges:=False
'Get next file name
Debug.Print myFile
myFile = Dir
Loop
End Sub
Function fileLoation(filePath As String, LookUpStr As String) As String
Dim financeStr As String
Dim myFile1 As String
financeStr = "*FIN*.xls"
myFile1 = Dir(filePath & financeStr)
Do While Len(myFile1) > 0
Debug.Print ("")
Debug.Print (myFile1)
' If InStr(myFile1, LookUpStr) > 0 Then
' fileLoation = myFile1
' Else
' fileLoation = ""
' End If
myFile1 = Dir
Loop
End Function
The issue is that when the myFIle1 = Dir in the function finishes executing, the original myFile = Dir also is at its end (at least I think it is)
There is no way around this issue, that's just how the Dir Function works.
Instead, look into using a FileSystem object in the sub-function.
Alternatively, you can store all the filenames in the main function into an Array to loop thru instead of nesting your Dir functions like this:
Dim sFiles() as String
Dim sFilename as String
ReDim sFiles(0)
sFilename = Dir(myPath & "*CITIES*.xls")
Do Until sFilename = ""
ReDim Preserve sFiles(UBound(sFiles) + 1)
sFiles(UBound(sFiles)) = sFilename
sFilename = Dir()
Loop
Then you have found all your CITIES in a 1 based Array to loop thru.
I was working with a vba and I'm trying to open all excel files in a folder (about 8-10) based on cell values. I was wondering if this is the right approach to opening it, it keeps giving me syntax error where I wrote the directory. and when I rewrote that section, the vba only shot out the msgbox which meant it had to have looped and did something right? but didn't open any files. Any information will help. Thank you guys so much for taking the time to help me in any way.
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
This worked for me perfectly
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
one of the issue was, you had to write
Workbooks.Open Filename:=Directory & MyFile
instead of
Workbooks.Open Filename:=MyFile
Corrected some issues with your code and cleaned it up, give this a try. I think the big issue was you had an extra double-quote, and you missing the ending \ in the Directory line:
Sub OpenFiles()
Dim QualityHUB As Workbook
Dim search As Worksheet
Dim customer As String
Dim customerfolder As String
Dim Directory As String
Dim MyFile As String
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = QualityHUB.Worksheets("Search")
customer = search.Range("$D$1").Value
customerfolder = search.Range("$D$3").Value
If Len(Trim(customer)) = 0 Or Len(Trim(customerfolder)) = 0 Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\" '<--- This requires the ending \
MyFile = Dir(Directory & "*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End Sub
I found this code online and it will open all the excel files in a folder, you can adapt the code to apply a function to the workbook, once it is open.
Option Explicit
Type FoundFileInfo
sPath As String
sName As String
End Type
Sub find()
Dim iFilesNum As Integer
Dim iCount As Integer
Dim recMyFiles() As FoundFileInfo
Dim blFilesFound As Boolean
blFilesFound = FindFiles("G:\LOCATION OF FOLDER HERE\", _
recMyFiles, iFilesNum, "*.xlsx", True)
End Sub
Function FindFiles(ByVal sPath As String, _
ByRef recFoundFiles() As FoundFileInfo, _
ByRef iFilesFound As Integer, _
Optional ByVal sFileSpec As String = "*.*", _
Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean
Dim iCount As Integer '* Multipurpose counter
Dim sFileName As String '* Found file name
Dim wbResults, file, WS_Count, i, gcell, col, finRow, wbCodeBook As Workbook, lCount, name, looper
Dim WorksheetExists
Set wbCodeBook = ThisWorkbook
'*
'* FileSystem objects
Dim oFileSystem As Object, _
oParentFolder As Object, _
oFolder As Object, _
oFile As Object
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set oParentFolder = oFileSystem.GetFolder(sPath)
If oParentFolder Is Nothing Then
FindFiles = False
On Error GoTo 0
Set oParentFolder = Nothing
Set oFileSystem = Nothing
Exit Function
End If
sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
'*
'* Find files
sFileName = Dir(sPath & sFileSpec, vbNormal)
If sFileName <> "" Then
For Each oFile In oParentFolder.Files
If LCase(oFile.name) Like LCase(sFileSpec) Then
iCount = UBound(recFoundFiles)
iCount = iCount + 1
ReDim Preserve recFoundFiles(1 To iCount)
file = sPath & oFile.name
name = oFile.name
End If
On Error GoTo nextfile:
Set wbResults = Workbooks.Open(Filename:=file, UpdateLinks:=0)
''insert your code here
wbResults.Close SaveChanges:=False
nextfile:
Next oFile
Set oFile = Nothing '* Although it is nothing
End If
If blIncludeSubFolders Then
'*
'* Select next sub-forbers
For Each oFolder In oParentFolder.SubFolders
FindFiles oFolder.path, recFoundFiles, iFilesFound, sFileSpec, blIncludeSubFolders
Next
End If
FindFiles = UBound(recFoundFiles) > 0
iFilesFound = UBound(recFoundFiles)
On Error GoTo 0
'*
'* Clean-up
Set oFolder = Nothing '* Although it is nothing
Set oParentFolder = Nothing
Set oFileSystem = Nothing
End Function
Function SSCGetColumnCodeFromIndex(colIndex As Variant) As String
Dim tstr As String
Dim prefixInt As Integer
Dim suffixInt As Integer
prefixInt = Int(colIndex / 26)
suffixInt = colIndex Mod 26
If prefixInt = 0 Then
tstr = ""
Else
prefixInt = prefixInt - 1
tstr = Chr(65 + prefixInt)
End If
tstr = tstr + Chr(65 + suffixInt)
SSCGetColumnCodeFromIndex = tstr
End Function
Function GetColNum(oSheet As Worksheet, name As String)
Dim Endrow_Col, i
'For loop to get the column number of name
Endrow_Col = oSheet.Range("A1").End(xlToRight).Column
oSheet.Select
oSheet.Range("A1").Select
For i = 0 To Endrow_Col - 1 Step 1
If ActiveCell.Value <> name Then
ActiveCell.Offset(0, 1).Select
ElseIf ActiveCell.Value = name Then
GetColNum = ActiveCell.Column
Exit For
End If
Next i
End Function
Function ShDel(name As String)
End If
End Function
I have recently started using VBA code, and after several hours searching the web for ideas or help i have run into a wall.
Since this site seems to get the best reponses, i was wandering if someone could help me figure out how to Find a certain Trade ID which consists of three letters which are either; VAL, DIV, or LIF; and then a series of numbers.
My Idea was to have the Trade ID typed into a cell, for example C4, and then click a button on the same sheet that would search the entire folder for that trade ID, since they are very unique only 1 file should open maybe two.
Thanks and let me know your thoughts and whether it is possible and how long it would take me to write this code and what sort of code i should use!
Edit:
Here is my code so far:
Private Sub CommandButton1_Click()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("X:\Ops\Trades\Repository\")
While (file <> "")
If InStr(file, Cells(3, 4)) > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
Edit:
Some Code I found and edited, however just crashes my pc when i run it.
'Definitions
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim CellSearchBook As Worksheet
Dim strFile As String
strFile = Application.GetOpenFilename
Set CellSearchBook = Workbooks.Open(strFile).Sheets(1)
CellRef = InputBox("Please enter Horseshoe Cell Reference to search for")
MyPath = "F:\Ops\Trades\Files\"
'If no files found
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Array myfiles will be filled
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Run through all files
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
Dim ws As Worksheet
For Each ws In mybook.Worksheets
If .ProtectContents = True Then
With ws
Application.ScreenUpdating = False
If InStr(1, ws.Range("K11").Value, CellRef, vbTextCompare) <> 0 Then
ws.Range("H1").Copy Destination:=CellSearchBook.Range("A10")
Application.CutCopyMode = False
Else
End If
Else
ErrorYes = True
End If
End With
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
End Sub
If this helps you - it returns an array of filenames:
Private Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
You need something like this (This is quickly spliced together from some different modules that I have, so it may not work out of the box):
Dim FolderObj, FSO, FileObj As Object
Dim FolderDialog As FileDialog
Dim FolderLocation As String
Dim Check As Boolean
'Create and run dialog box object
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = "C:\"
.InitialView = msoFileDialogViewDetails
If .Show = -1 Then
FolderLocation = .SelectedItems.Item(1)
Check = True
Else
Check = False
End If
End With
'Check if user canceled dialog box
'Exit if yes
If Check = False Then
MsgBox "No Folder Selected"
Exit Sub
End If
'Create a File System Object to be the folder that was selected
Set FSO = CreateObject("scripting.filesystemobject")
Set FolderObj = FSO.getfolder(FolderLocation)
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Set ExApp = New Excel.Application
ExApp.Visibility = False 'Set the application visibility to false to speed it up and run in the background while it searches your workbooks
For Each FileObj In FolderObj.Files
If Right(FileObj.Name, 3) = "xls" Then
Set ExWbk = ExApp.Workbooks.Open(FolderObj & "\" & FileObj.Name)
'Some sort of search for the workbook
'Some sort of return to your workbook
ExWbk.Close
end if
Next
Again, this doesn't exactly solve your problem, but it does give you a pretty decent starting point
I have worked on this for a while. It's my first Excel VBA macro and I think I am almost there. I just can't seem to find a way to get the information I need from my function or I can't get my function to give me the right information.
I need a macro that will search through a selected folder and its sub-folders for excel workbooks that have specific sheet names contained with in then out put the paths to an excel spreadsheet. Currently my code will either only find the files in a single folder or it will list all the files indiscriminately. Now the code is a bit of a mess because i am unsure of which parts I need and which parts I don't.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim FileToWriteTo As Variant
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr$ = "C:"
'Define filetype
FileType = "*.xlsx"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'If user selects folder count the items to search
xDirect$ = MyDir & "\"
xFname$ = Dir(xDirect$, 8)
'Creates list with filenames
FileList = ListFiles(xDirect$ & FileType)
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(FileList)
'Opens file
Workbooks.Open (xDirect$ & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname$ = Dir(xDirect$ & FileList(i))
Do While xFname$ <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = xDirect$ & xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
'Copies sheet
'ActiveWorkbook.Sheets(GrabSheet).Copy after:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
' End If
'End With
'End Function
End Sub
'WITH SUBFOLDERS - Function that creates an array with all the files in the folder
Private Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function
'WITHOUT SUBFOLDERS - Function that creates an array with all the files in the folder
Function ListFiles(Source As String) As Variant
Dim GetFileNames() As Variant
Dim i As Integer
Dim FileName As String
On Error GoTo ErrHndlr
i = 0
FileName = Dir(Source)
If FileName = "" Then GoTo ErrHndlr
'Loops until no more mathing files are found
Do While FileName <> ""
i = i + 1
ReDim Preserve GetFileNames(1 To i)
GetFileNames(i) = FileName
FileName = Dir()
Loop
ListFiles = GetFileNames
On Error GoTo 0
Exit Function
'If error
ErrHndlr:
ListFiles = False
On Error GoTo 0
End Function
This will work right now to give a list using the "ListFiles" Function.
But I can't seem to figure out how to get it to out put a list using the "SearchFiles" Function. Which, ultimately,is what I need it to do.
Please help i feel like I am so close!!!
Ok i figured it out. I was having trouble with the syntax to access my array of arrays. here is the code that ended up doing the trick.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim GrabSheet As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim xRow As Long
Dim xFname As String
Dim InitialFoldr As String
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr = "C:\Users\george.EASYWAY\Desktop\TEST1\"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Default:="snagit", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(myList, 2)
'Opens file
Workbooks.Open (myList(1, (i)) & "\" & (myList(2, (i))))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname = Dir(myList(1, (i)) & "\" & (myList(2, (i))))
Do While xFname <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = (myList(1, (i)) & "\" & (myList(2, (i))))
xRow = xRow + 1
xFname = Dir
Loop
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
End Sub
'Function that creates an array with all the files in the folder with subfolders
Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function