Similar VBScript for converting Excel and PowerPoint to PDF - excel

I am looking for a completely lossless way of converting Excel and PowerPoint documents to PDF. I am using this script for Word and it works flawlessly https://gallery.technet.microsoft.com/office/Script-to-convert-Word-08c5154b. I am looking for a similar script for Excel and PowerPoint and cant find one on the internet. I dont have much experience with VB at all so I am confused where it specifies which office application to use. Is there anyone that can provide one for Excel and PowerPoint or someone proficient in VB that would be able to change the script to work with the other packages? I assume its just changing the intent as the programs integrated save as PDF option is the same?
The script for Word is below as well:
Option Explicit
'################################################
'This script is to convert Word documents to PDF files
'################################################
Sub main()
Dim ArgCount
ArgCount = WScript.Arguments.Count
Select Case ArgCount
Case 1
MsgBox "Please ensure Word documents are saved,if that press 'OK' to continue",,"Warning"
Dim DocPaths,objshell
DocPaths = WScript.Arguments(0)
StopWordApp
Set objshell = CreateObject("scripting.filesystemobject")
If objshell.FolderExists(DocPaths) Then 'Check if the object is a folder
Dim flag,FileNumber
flag = 0
FileNumber = 0
Dim Folder,DocFiles,DocFile
Set Folder = objshell.GetFolder(DocPaths)
Set DocFiles = Folder.Files
For Each DocFile In DocFiles 'loop the files in the folder
FileNumber=FileNumber+1
DocPath = DocFile.Path
If GetWordFile(DocPath) Then 'if the file is Word document, then convert it
ConvertWordToPDF DocPath
flag=flag+1
End If
Next
WScript.Echo "Totally " & FileNumber & " files in the folder and convert " & flag & " Word Documents to PDF fles."
Else
If GetWordFile(DocPaths) Then 'if the object is a file,then check if the file is a Word document.if that, convert it
Dim DocPath
DocPath = DocPaths
ConvertWordToPDF DocPath
Else
WScript.Echo "Please drag a word document or a folder with word documents."
End If
End If
Case Else
WScript.Echo "Please drag a word document or a folder with word documents."
End Select
End Sub
Function ConvertWordToPDF(DocPath) 'This function is to convert a word document to pdf file
Dim objshell,ParentFolder,BaseName,wordapp,doc,PDFPath
Set objshell= CreateObject("scripting.filesystemobject")
ParentFolder = objshell.GetParentFolderName(DocPath) 'Get the current folder path
BaseName = objshell.GetBaseName(DocPath) 'Get the document name
PDFPath = parentFolder & "\" & BaseName & ".pdf"
Set wordapp = CreateObject("Word.application")
Set doc = wordapp.documents.open(DocPath)
doc.saveas PDFPath,17
doc.close
wordapp.quit
Set objshell = Nothing
End Function
Function GetWordFile(DocPath) 'This function is to check if the file is a Word document
Dim objshell
Set objshell= CreateObject("scripting.filesystemobject")
Dim Arrs ,Arr
Arrs = Array("doc","docx")
Dim blnIsDocFile,FileExtension
blnIsDocFile= False
FileExtension = objshell.GetExtensionName(DocPath) 'Get the file extension
For Each Arr In Arrs
If InStr(UCase(FileExtension),UCase(Arr)) <> 0 Then
blnIsDocFile= True
Exit For
End If
Next
GetWordFile = blnIsDocFile
Set objshell = Nothing
End Function
Function StopWordApp 'This function is to stop the Word application
Dim strComputer,objWMIService,colProcessList,objProcess
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
'Get the WinWord.exe
Set colProcessList = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE Name = 'Winword.exe'")
For Each objProcess in colProcessList
'Stop it
objProcess.Terminate()
Next
End Function
Call main

This will convert all Excel files into PDF files.
Sub Convert_Excel_To_PDF()
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 LPosition As Integer
'Fill in the path\folder where the Excel files are
MyPath = "c:\Documents and Settings\shuerya\Desktop\ExcelFiles\"
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
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
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
LPosition = InStr(1, mybook.Name, ".") - 1
mybookname = Left(mybook.Name, LPosition)
mybook.Activate
'All PDF Files get saved in the directory below:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Documents and Settings\shuerya\Desktop\PDFFiles\" & mybookname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
mybook.Close SaveChanges:=False
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Can you work with that??

Related

convert all excel files to pdf in their own subfolder vba

ı would like to convert all excel files to pdf as the whole workbook in subfolders to their original subfolders
I have one solution but my computer is limited. so PowerShell is not supported
How can I convert .XLS & .XLXS files to .PDF format and return them to each original subfolder in Powershell?
This is how I would do it.
http://www.rondebruin.nl/copy5_3.htm
Sub Convert_Excel_To_PDF()
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 LPosition As Integer
'Fill in the path\folder where the Excel files are
MyPath = "c:\your_path_here\"
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
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
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
LPosition = InStr(1, mybook.Name, ".") - 1
mybookname = Left(mybook.Name, LPosition)
mybook.Activate
'All PDF Files get saved in the directory below:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Documents and Settings\shuerya\Desktop\PDFFiles\" & mybookname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
mybook.Close SaveChanges:=False
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Search some text/word in folder containing bunch of PDF files and get count of PDF contains that text/word - Without opening pdf files

Aim - I want VBA code that should search specific text/word in content inside bunch of pdf files and give me COUNT of PDF contains that word (without opening pdf files)
Currently I have code found on internet giving me count of PDF files that contains specific text in the > Name of pdf files <
But as mentioned I want to modify below code/give me new code that should give me COUNT of pdf files contains that specific word inside the PDF content
Below is the current code I have
Sub PDFCONTENT()
Dim i As Long
Dim x As Integer
Dim Folder As String
Dim ExcelFN As String
Dim NumFiles As Integer
Dim filename As String
Dim FinsS As String
For i = 2 To Range("A" & Rows.count).End(xlDown).Row
NumFiles = 0
Folder = Sheets("Sheet1").Range("A" & i).Value
ExcelFN = Sheets("Sheet1").Range("B" & i).Value
filename = Dir(Folder & "*" & ExcelFN & "*")
Do While filename <> ""
NumFiles = NumFiles + 1
filename = Dir()
Loop
Sheets("Sheet1").Range("C" & i) = NumFiles
Next i
End Sub
I don't see how you will get the content of the PDF files, or any files for that matter, without opening the files. Also, you will need Adobe Acrobat installed to scan PDF files using VBA. I don't know how much it costs, but it's not free. If you want a free option, convert all PDF files into Word files and then do scans on those.
Sub ConvertToWord()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\Excel\Desktop\test\" & "*.pdf") 'pdf path
Do While (file <> "")
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\"
Documents.Open FileName:=file, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\" 'path for saving word
ActiveDocument.SaveAs2 FileName:=Replace(file, ".pdf", ".docx"), FileFormat:=wdFormatXMLDocument _
, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=15
ActiveDocument.Close
file = Dir
Loop
End Sub
Then, run this code below, in Excel.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
Dim iCount As Long
Dim strSearch As String
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\test\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
strSearch = ws.Cells(1, c).Value
iCount = 0
With ActiveDocument.Content.Find
.Text = strSearch
.Format = False
.Wrap = wdFindStop
Do While .Execute
iCount = iCount + 1
Loop
End With
ws.Cells(r, c).Value = iCount
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
Here, the counts are the same because I copied/pasted the same file 4x so I had something to loop over.

Excel VBA to convert all Word files in a specific folder to PDF [closed]

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I've found in below link an Excel vba that converts excel files in a specific directory to pdfs.
I want your help to do the needful changes on this code to make it converts Word documents in a specific directory to pdfs.
credits to:
https://www.listendata.com/2013/02/excel-macro-convert-multiple-excel.html
Code is shown below:
Sub ExcelToPDF2()
Dim Path As String, FilesInPath As String _
, OutputPath As String, OutputPath2 As String
Dim MyFiles() As String, Fnum As Long
Dim Buk As Workbook, BukName As String
Dim CalcMode As Long
Dim sh As Worksheet
Dim StartTime As Date, EndTime As Date
Dim LPosition As Integer
'Specify the path of a folder where all the excel files are stored
StartTime = Timer
Path = Range("G6").Text & "\"
OutputPath = Range("G8").Text & "\"
FilesInPath = Dir(Path & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
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
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set Buk = Nothing
On Error Resume Next
Set Buk = Workbooks.Open(Path & MyFiles(Fnum))
On Error GoTo 0
If Not Buk Is Nothing Then
LPosition = InStr(1, Buk.Name, ".") - 1
BukName = Left(Buk.Name, LPosition)
Buk.Activate
OutputPath2 = OutputPath & BukName & ".pdf"
On Error Resume Next
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=OutputPath2,
_
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
On Error GoTo 0
End If
Buk.Close SaveChanges:=False
Next Fnum
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
EndTime = Timer
MsgBox "Task succesfully completed in " & Format(EndTime - StartTime,
"0.00") & " seconds"
End Sub
I've finally found the correct VBA I was looking for:
'In your VBA window go to tools then references and add a reference to
'Microsoft Word
Sub Converter()
Dim cnt As Integer, currfile As String
Dim TrimFile As String, Path As String, FilesInPath As String _
, MyFiles() As String, Fnum As Long
Dim CalcMode As Long, LPosition As Long
Dim StartTime As Date, EndTime As Date
Dim objWord As Word.Application
Dim objDoc As Word.Document
ThisWorkbook.Activate
currfile = ActiveWorkbook.Name
Windows(currfile).Activate
Sheets("Sheet1").Activate
StartTime = Timer
Path = Range("C3").Text & "\"
FilesInPath = Dir(Path & "*.doc*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
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
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set objWord = CreateObject("Word.Application")
'objWord.Visible = True
On Error Resume Next
Set objDoc = Word.Documents.Open(Path & MyFiles(Fnum))
On Error GoTo 0
If Not objDoc Is Nothing Then
LPosition = InStr(1, objDoc.Name, ".") - 1
TrimFile = Left(objDoc.Name, LPosition)
On Error Resume Next
objDoc.ExportAsFixedFormat OutputFileName:=objDoc.Path & "\" & TrimFile & ".pdf",
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
End If
objDoc.Close
Next Fnum
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
EndTime = Timer
MsgBox " Task succesfully completed in " & Format(EndTime - StartTime, "0.00") & "
seconds"
End Sub
Honestly, the easiest way I can think of to do this is to just record a macro. If you go to Word->Developer->Record a Macro, you can record the function that you want to do. From there, you would have the code, and you can change certain areas from there. Here is the code I got with a few tweaks to do what I think you are looking for:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim i As Integer, FileLocation As String, WDoc() As Word.Document
Dim FilesInPath As String, Path As String, MyFiles() As String, iend As Integer
Path = "C:\...\" ' This is where you would like to get the files that need to be exported to .pdfs
NewPath = "C:\...\" ' This is where you would like to send the exported files
FilesInPath = Dir(Path & "*.doc*")
iend = 0
Do While FilesInPath <> ""
iend = iend + 1
ReDim Preserve MyFiles(1 To iend)
MyFiles(iend) = FilesInPath
FilesInPath = Dir()
Loop
For i = 1 To iend
ReDim Preserve WDoc(i)
Set WDoc(i) = Word.Documents.Open(Path & MyFiles(i))
FileLocation = NewPath & WDoc(i).Name & ".pdf" ' Location and name of new file
WDoc(i).ExportAsFixedFormat OutputFileName:=FileLocation, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
WDoc(i).Close
Next i
End Sub

Copying 1 file into multiple subdirectories

I have found one code snippet that successfully copies 1 file to one specific directory. However what I am trying to piece together is a way to copy one file into hundreds of subdirectories. I have also found code that recursively cycles through subfolders and allows you to take action upon the files in the subfolders. Surely there must be a mash up of these two codes that would allow me to copy the 1 file into numerous subdirectories.
If this is not possible I have working code for a command prompt.
Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim fso As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
'FromPath = "C:\Users\Ron\Data" '<< Change
'ToPath = "C:\Users\Ron\Test" '<< Change
FileExt = "*.pdf" '<< Change
'You can use *.* for all files or *.doc for Word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set fso = CreateObject("scripting.filesystemobject")
If fso.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If fso.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
fso.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Code that cycles through subfolders:
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub
Any advice is welcome!
Try the following code:
'*****************************************************
' FUNCTION HEADER: Put_A_File_In_All_Subfolders
'
' Purpose: Looks for the specified file, and if it exists it
' puts the file in all subfolders of the target path.
'
' Inputs:
' blnFirstIteration: True / false for whether this is the first function call
' strFromPath As String: The path where the file to copy is located.
' strToPath As String: The path where the destination folder tree exists.
' strFileToCopy: The filename to copy.
'*****************************************************
Sub Put_A_File_In_All_Subfolders( _
blnFirstIteration As Boolean, _
strFromPath As String, _
strToPath As String, _
strFileToCopy As String)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim blnEverythingIsValid As Boolean
blnEverythingIsValid = True
'If this is the first run, check to make sure the initial file
'exists at that path, else throw error messages:
If blnFirstIteration Then
If Right(strFromPath, 1) <> "\" Then
strFromPath = strFromPath & "\"
End If
If fso.FolderExists(strFromPath) = False Then
MsgBox strFromPath & " doesn't exist"
blnEverythingIsValid = False
Else
If Not fso.FileExists(strFromPath & strFileToCopy) Then
MsgBox strFileToCopy & " doesn't exist in " & strFromPath
blnEverythingIsValid = False
End If
End If
If fso.FolderExists(strToPath) = False Then
MsgBox strToPath & " doesn't exist"
blnEverythingIsValid = False
End If
End If
If blnEverythingIsValid Then
If Right(strToPath, 1) <> "\" Then
strToPath = strToPath & "\"
End If
'Copy the file to the destination folder
fso.CopyFile (strFromPath & strFileToCopy), strToPath, True
'Run the sub recursively for each subfolder
Dim vntSubFolder As Variant
Dim currentFolder As Scripting.Folder
Set currentFolder = fso.GetFolder(strToPath)
'Check to see if there are subfolders
If currentFolder.SubFolders.Count > 0 Then
For Each vntSubFolder In currentFolder.SubFolders
'Dim fsoSubFolder As Scripting.Folder
'Set fsoSubFolder = currentFolder.SubFolders.item(vntSubFolder)
Dim strSubFolderPath As String
strSubFolderPath = vntSubFolder.Path
Put_A_File_In_All_Subfolders False, strFromPath, strSubFolderPath, strFileToCopy
Next vntSubFolder
End If
Else
Set fso = Nothing
Exit Sub
End If
Set fso = Nothing
End Sub
You can call it using:
Put_A_File_In_All_Subfolders True, "C:\PathWithFile\", "C:\RootDestinationFolder", "Filename.ext"
I mashed that up quickly, so please test before using widely...

vba excel: open files (known filename) from multiple folders

I'm trying to figure out how to import text files (always named tracks.txt) from different folders into one workbook with separate worksheets named after the folder.
basically it should work like this:
select main folder
select multiple sub-folders (which contain the tracks.txt)
or
search in all sub-folders starting with the string (user input)
import tracks.txt in new worksheet
replace worksheetname with subfoldername
would this be possible?
'//-----------------------------------------------------------------------------------------\\
'||code was made with the great help of bsalv and especially snb from www.worksheet.nl ||
'||adjusted and supplemented for original question by myself martijndg (www.worksheet.nl) ||
'\\-----------------------------------------------------------------------------------------//
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select folder with subfolder (containing tracks.txt) NO SPACES IN FILEPATH!!!"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1) + "\" 'laatste slash toegevoegd aan adres
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub importtracks()
Dim subfolder, serie As String
c00 = GetFolder("C:\")
serie = InputBox(Prompt:="partial foldername of serie", _
Title:="find folders of 1 serie", Default:="track##.")
If serie = "track##." Or serie = vbNullString Then
Exit Sub
End If
Workbooks.Add
For Each it In Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & c00 & "tracks.txt /b /s").stdout.readall, vbCrLf), ":")
sn = Split(CreateObject("scripting.filesystemobject").opentextfile(it).readall, vbCrLf)
With Sheets
subfolder = Replace(Replace(CreateObject("scripting.filesystemobject").GetParentFolderName(it), "" & c00 & "", ""), "\", "")
End With
If InStr(1, subfolder, serie, vbTextCompare) Then
With Sheets.Add
.Move after:=Sheets(Sheets.Count)
.name = subfolder
.Cells(1).Resize(UBound(sn) + 1) = WorksheetFunction.Transpose(sn)
.Columns(1).TextToColumns , xlDelimited, semicolon:=True
End With
End If
Next
If Sheets.Count = 3 And Sheets(Sheets.Count).name = "Sheet3" Then
MsgBox "no subfolder contained the string '" & serie & "' or your choosen filepath contained spaces"
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
End If
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
End Sub

Resources