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 trying to load a listbox with files in a folder through MFDialogbox Picker.
Unfortunately, its not working. Request your help.
Below is the code, I am using. Thanks
I find that 'mypath' variable is holding the correct name of the folder that was selected.
But, I find nothing is working thereafter. Please help.
Private Sub UserForm_Initialize()
Dim myfiles As String, mypath As String
Dim fileList() As String
Dim fName As String
Dim fPath As String
Dim I As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then Exit Sub
mypath = .SelectedItems(1)
DoEvents
End With
MsgBox mypath
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
ReDim fileList(1 To I)
fName = Dir(mypath)
MsgBox fName
While fName <> ""
'add fName to the list
I = I + 1
ReDim Preserve fileList(1 To I)
fileList(I) = fName
'get next filename
fName = Dir()
Wend
'see if any files were found
If I = 0 Then
MsgBox "No files found"
Exit Sub
End If
'cycle through the list and add to listbox
For I = 1 To UBound(fileList)
Me.ListBox1.AddItem fileList(I)
Next
End Sub
The problem is that I is 0 (as it is not set) when reaching ReDim fileList(1 To I). If you replace it with ReDim fileList(1 To 1), it should work.
I want to open Excel xlsx file without writing path by using variables. I din't know why but it is not working. I have a folder with the main workbook and another one that I want to open that is xlsx. I want to name it UnionWB.
Private Sub cmdStartMonth_Click()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
'Analyze month by selecting
Dim myPath As String
Dim myFile As String
Dim UnionWB As Workbook
Dim MonthName As String
MonthName = ListMonth.Value
myExtension = "*.xlsx*"
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & myExtension)
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & myExtension)
Here's a couple of examples that may help.
The first will ask you to select the correct file and then open it:
Public Sub Test()
Dim sWrkbkPath As String
Dim UnionWB As Workbook
sWrkbkPath = GetFile(ThisWorkbook.Path)
If sWrkbkPath <> "" Then
Set UnionWB = Workbooks.Open(sWrkbkPath)
MsgBox UnionWB.Name
End If
End Sub
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select your Union Workbook"
.AllowMultiSelect = False
.Filters.Add "My Union Workbook", "*.xlsx", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
The second method assumes you only have a single xlsx file in the same folder as ThisWorkbook and opens the first file it finds:
Public Sub OpenOnlyXLSXInFolder()
Dim sWrkbkPath As String
Dim UnionWB As Workbook
sWrkbkPath = Dir$(ThisWorkbook.Path & "\*.xlsx")
'Only expecting a single file so no need to loop.
If sWrkbkPath <> "" Then
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & "\" & sWrkbkPath)
MsgBox UnionWB.Name
End If
End Sub
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 had a large number of doc files that I wanted to convert to docx files.
I discovered that there was not a really good way to automatically do this conversion.
I have submitted the method I used to do this but perhaps there are now other ways.
I found a few thing that might help:
Microsoft Bulk Converter
Simple Microsoft Word macro
However I was not satisfied with macro provided. I needed something recursive to also convert nested files. So I expanded it to do so.
Sub SaveAllAsDOCX()
'Search #EXT to change the extensions to save to docx
Dim strDocName As String
Dim strPath As String
Dim oDoc As Document
Dim fDialog As FileDialog
Dim intPos As Integer
'Create a folder dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select root folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
'Select root folder
strPath = fDialog.SelectedItems.Item(1)
'Ensure the Folder Name ends with a "\"
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
'Close any open documents
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
'remove any quotes from the folder string
If Left(strPath, 1) = Chr(34) Then
strPath = Mid(strPath, 2, Len(strPath) - 2)
End If
'begin recusion
recurse (strPath)
End Sub
'This method controls the recusion
Function recurse(folder As String)
'save all the files in the current folder
SaveFilesInFolder (folder)
'get all the subfolders of the current folder
Dim folderArray
folderArray = GetSubFolders(folder)
'Loop through all the non-empty elements for folders
For j = 1 To UBound(folderArray)
If folderArray(j) <> "" Then
'begin recusion on subfolder
recurse (folder & folderArray(j) & "\")
End If
Next
End Function
'Saves all files with listed extensions
Function SaveFilesInFolder(folder As String)
'List of extensions to look for #EXT
Dim strFilename As String
extsArray = Array("*.rtf", "*.doc")
'Loop through extensions
For i = 0 To (UBound(extsArray))
'select the 1st file with the current extension
strFilename = Dir(folder & extsArray(i), vbNormal)
'double check the current extension (don't to resave docx files)
Dim ext As String
ext = ""
On Error Resume Next
ext = Right(strFilename, 5)
If ext = ".docx" Or ext = "" Then
'Don't need to resave files in docx format
Else
'Save the current file in docx format
While Len(strFilename) <> 0
Set oDoc = Documents.Open(folder & strFilename)
strDocName = ActiveDocument.FullName
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
strDocName = strDocName & ".docx"
oDoc.SaveAs FileName:=strDocName, _
FileFormat:=wdFormatDocumentDefault
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFilename = Dir
Wend
End If
Next
strFilename = ""
End Function
'List all the subfolders in the current folder
Function GetSubFolders(RootPath As String)
Dim FS As New FileSystemObject
Dim FSfolder As folder
Dim subfolder As Variant
Set FSfolder = FS.GetFolder(RootPath)
'subfolders is variable length
Dim subfolders() As String
ReDim subfolders(1 To 10)
Dim i As Integer
i = LBound(subfolders)
For Each subfolder In FSfolder.subfolders
subfolders(i) = subfolder.Name
'increase the size of subfolders if it's needed
i = i + 1
If (i >= UBound(subfolders)) Then
ReDim subfolders(1 To (i + 10))
End If
Next subfolder
Set FSfolder = Nothing
GetSubFolders = subfolders
End Function
Yeah I know it's a lot of code. :)