Reference name-changing workbook in VBA - vba

I was wondering whether there is a (built in/simple) option to reference/connect/link to a workbook that has a variable name?
My xy-problem is, I have workbook b v45.xlsm and wish to export data to workbook a v34.xlsm where the version numbers vary. So I was wondering if there is a sub-ID for each workbook, to which excel can refence independent of the name, automatically picking the most recent version in that folder.
Of course the simple solution is to pick the most recently modified excel file in the folderpath containing the string "a v", assuming an identical folderpath, but I was curious if there was a more convential/integrated option for this.
Kind regards.
(For future people looking at this issue, here is my manual solution:)
Sub find_planner_name()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim string_object(0 To 2) As String 'saving the filenames as strings
Dim count As Integer 'counting nr of files encountered
Dim save_version_number(0 To 1) As Long
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
'Cells(i + 1, 1) = objFile.name
count = count + 1
ReDim version_number(0 To count) As Long
string_object(0) = ""
string_object(1) = ""
string_object(2) = ""
string_object(0) = objFile.name
If Right(string_object(0), 5) = ".xlsm" Or Right(string_object(0), 5) = ".xlsb" Then
If Left(string_object(0), 10) = " planner v" Or Left(string_object(0), 10) = " planner v" Then
string_object(1) = Right(string_object(0), Len(string_object(0)) - 10)
MsgBox (string_object(1))
Do While IsNumeric(Left(string_object(1), 1)) = True
If IsNumeric(Left(string_object(1), 1)) = True Then
string_object(2) = string_object(2) & Left(string_object(1), 1)
string_object(1) = Right(string_object(1), Len(string_object(1)) - 1)
End If
Loop
If version_number(count) < string_object(2) And string_object(2) > 0 Then
version_number(count) = string_object(2)
MsgBox (version_number(count))
save_version_number(0) = version_number(count)
save_version_number(1) = count
End If
End If
End If
i = i + 1
Next objFile
count = save_version_number(1) 'rewrite maxima back
version_number(count) = save_version_number(0) 'rewrite maxima back
'MsgBox ("done " & version_number(count))
Dim myMax As Long
Dim count_results As Long
For count_results = LBound(version_number, 1) To UBound(version_number, 1)
If version_number(count_results) > myMax Then
myMax = version_number(count_results)
Findmax = count_results
'MsgBox (version_number(count_results))
End If
'MsgBox (version_number(count_results) & " and count_results = " & count_results)
Next count_results
'the name of the planner =
name_planner = " planner v" & version_number(Findmax) & ".xlsm"
' check if xlsm or xlsb
'MsgBox (name_planner)
If Dir(ThisWorkbook.Path & "\" & name_planner) <> "" Then
MsgBox ("File exists. and name is " & name_planner)
Else
name_planner = " planner v" & version_number(Findmax) & ".xlsb"
End If
End Sub

It should be more reliable to parse filenames looking at the version numbers rather than looking at the most recently modified file. Loop through all of them checking the filename with something like:
strFile = Dir(DirectoryPath)
Do while strFile <> ""
'Code here to parse strFile for intNewVersionNumber
if intNewVersionNumber > intVersionNumber then intVersionNumber = intNewVersionNumber
strFile = Dir
Loop
strFile = 'Code here to reconstruct filename from intVersionNumber
From your question, I think this might actually be necessary, even though there may be a couple of ways of adding/checking metadata on Excel files.
When you say the workbook name changes, it is literally the exact same file being renamed through Windows Explorer, or do you have multiple versions in the same folder created when you use Save As...? The issue of "automatically picking the most recent version" suggests that there are new versions being created in the same folder. If so, it means that you're actually changing which workbook you're linking to, so any kind of link to a file isn't going to work anyway. Also, even if you put in a sub-ID, each version will still have that same sub-ID. While this can still identify the files that are different versions of the same file, you still have to loop through all of those files looking for the latest version. A sub-ID would help if the filename is changing entirely, but doesn't remove the need to search through the different versions. So, if you can keep a consistent filename with only the version number changing, you'll be able to implement the simplest solution possible.

Related

In Excel-Word Interop, how do I use the File Object after using the Name function to rename it?

Overall objective: create an Excel-based file converter that interops with Word, changing several built-in document properties, header/footer text & pics, watermark, and file name. The new attributes/text/file paths are found in cells. After changing all these attributes, et al, the file is to be copied as a regular .docx to a new Output folder and also exported as a PDF to a separate PDF Output folder. Optionally the files in the input folder will be deleted after the other steps are completed.
Specific problem: After I rename any of the files using the Name function, the File Object (I'm using File Scripting Object) loses its reference to the old file (since it's renamed), but does not pick up on the new, renamed file. After renaming the file, I would like to make a copy of it into the word document output folder; then, with the original, I would export it to the PDF output folder. Finally, I would either delete it or leave it alone, depending on an optional boolean.
I have attempted to re-assign the File Object with the new file, but this doesn't seem to be possible, and nothing else in its properties or methods makes sense to use.
Sub ChangeProperties()
Dim wordApp As Word.Application
Dim wordDoc() As Word.Document
Dim fso As New FileSystemObject
Dim fo(3) As Folder
Dim f As file
Dim cvSht As Worksheet
Dim fileSht As Worksheet
Dim progShp As Shape
Dim fileRng(0 To 13) As Range
Dim optRng As Range
Dim i As Long
Dim n As Long
Dim count As Long
Set wordApp = Word.Application
' Dashboard sheet
Set cvSht = Sheets("Convert")
' Sheet where user types new attributes or views old attributes
Set fileSht = Sheets("FileAttributes")
' Folder objects
Set fo(1) = fso.GetFolder(cvSht.Range("F3").Value)
Set fo(2) = fso.GetFolder(cvSht.Range("F5").Value)
Set fo(3) = fso.GetFolder(cvSht.Range("F7").Value)
ChDir (fo(1) & Application.PathSeparator)
Set optRng = cvSht.Range("H13")
' Just some user-defined true/false input cells
optERR = optRng
optMSG = optRng.Offset(1, 0)
optPDF = optRng.Offset(2, 0)
optDOC = optRng.Offset(3, 0)
optRMV = optRng.Offset(4, 0)
' Run some pre-execution checks to prevent catastrophic failure
If fo(1).Files.count > 20 Then
MsgBox "Too many files in folder. Please only 20 files at a time.", vbOKOnly, "Error!"
Exit Sub
End If
For i = 0 To 13
Set fileRng(i) = fileSht.Range("D27").Offset(0, i)
Next
n = 1
If InStr(1, fileRng(0).Offset(n - 1, 0), "doc") = 0 Then
MsgBox "New file names must end with a proper extension, i.e. - .docx", vbCritical, "Terminating Process!"
Exit Sub
End If
For Each f In fo(1).Files
For i = 0 To fo(1).Files.count
If fileRng(0).Value = f.Name Then
MsgBox "New file names must be different from the existing file names! Aborting...", vbCritical, "Terminating Process!"
Exit Sub
End If
Next
Next
For Each f In fo(1).Files
If optERR = False Then On Error Resume Next
If Left(f.Name, 1) = "~" Then GoTo Nxt
Set wordDoc(n) = wordApp.Documents.Open(f.Path)
' -------- Clipped out middle parts for clarity ---------
If fileRng(0).Offset(n - 1, 0) <> "" Then
End If
On Error GoTo 0
wordDoc(n).Save
Application.Wait Now + 0.00003
Application.StatusBar = "Processing..." & n & "/" & fo(1).Files.count
If optPDF Then
If Right(f, 1) = "x" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docx", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "c" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".doc", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "m" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docm", ".pdf"), wdExportFormatPDF
End If
End If
wordDoc(n).Close
**Name f.Name As fileRng(0).Offset(n - 1, 0).Value** ' Causes the next lines to fail
**Set f = fileRng(0).Offset(n - 1, 0).Value** ' Attempt to reassign fails
**If optDOC Then f.Copy (fo(3) & "/")** ' This would fail too
If optRMV Then f.Delete
Nxt:
On Error GoTo 0
n = n + 1
Next
End Sub

Combining CSV files from one folder into one file through MS Acces s vba

Hi there so I finished the section of a program which calculates and exports a csv with results. (ends up about 1600 csv files) each having only 1 column and between 20 and 0 rows. I would like my MS Access VBA program to join them together into one larger CSV. So Same header only once at the top of the new file.
The program i have so far seems to fall over at the part where it tries to import the Reg. Number of the File.
Dim db As DAO.Database
Set db = CurrentDb
MTH = Format(Date, "mmm")
UserInput = InputBox("Enter Country Code")
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim x As Variant
Dim Cnt As Long
Dim r As Long
Dim c As Long
Dim wks As Excel.Worksheet
Application.Echo False
'Change the path to the source folder accordingly
strSourcePath = "Q:\CCNMACS\AWD" & CTRY
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
'Change the path to the destination folder accordingly
strDestPath = "Q:\CCNMACS\AWDFIN"
If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
Cnt = Cnt + 1
If Cnt = 1 Then
r = 1
Else
r = Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Open strSourcePath & strFile For Input As #1
If Cnt > 1 Then
Line Input #1, strData
End If
Do Until EOF(1)
Line Input #1, strData
x = Split(strData, ",")
For c = 0 To UBound(x)
wks.Cells(r, c + 1).Value = Trim(x(c)) 'Error is here: Run time error '91': Object variable or With Block variable not set
Next c
r = r + 1
Loop
Close #1
Name strSourcePath & strFile As strDestPath & strFile
strFile = Dir
Loop
Application.Echo True
If Cnt = 0 Then _
MsgBox "No CSV files were found...", vbExclamation
Your question isn't absolutely definitive as to what you're trying to do, but if I understand correctly, you just need to append several files to the end of each other, to make "one big CSV".
If that's true then there are several ways to do this a lot simpler than using VBA. .CSV files are just plain text files with comma's separating each field, and a .CSV filename extension.
Personally I would use Notepad++ (I assume it's capable of this; it does everything else), or perhaps even easier, I would use the Windows Command Prompt.
Let's say you have a folder with files:
File1.csv
File2.csv
File3.csv
...etc
Open the Windows Command Prompt. (One way is with the Windows key + R, then type cmd and hit Enter.)
Change directory with to the file location using cd (same as ChDir).
(For example, you might use cd c:\users\myFolder,
and then hit Enter)
To combine all CSV's in the folder into one, you could use a command like:
copy *.csv combinedfile.csv
That's it!
A file is created named combinedfile.csv. You can open in Excel or a text editor (like Notepad) to double-check it and adjust manually if necessary.
Obviously there are many ways you could vary the command, like if you only wanted the files that start with the word File you could use:
copy file*.csv combinedFile.csv
This should do what you want.
Sub Import()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\your_path_here\"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "Table1"
strFile = Dir(strPath & "*.csv")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
DoCmd.TransferText acImportDelim, "", strTable, strPathFile, blnHasFieldNames
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
strFile = Dir()
Loop
End Sub
See the links below for additional details pertaining to this topic.
https://anthonysmoak.com/2018/04/10/how-to-fix-an-import-specification-error-in-microsoft-access/
https://www.oakdome.com/programming/MSAccess_ExportSpecifications_TransferText_To_CSV.php

Running List of CMD lines from Excel

Can anyone help please with the following requirements?
Requirement A:
I'd like to create a loop to run a list of command strings in CMD as long as there's a non-zero value in column C. I think I need to define a variable i for my starting row as this will always be the same, and then run Shell(), pulling the command string from the corresponding cell in Row i, Column F. While Cells(i, "C") is not blank, keep going, increasing i by 1.
Requirement B:
I'd also like to link this macro to work in a directory deposited in a cell by an earlier macro that listed all the files in a selected directory.
This is what I have, without any looping..
Sub Run_Renaming()
Dim CommandString As Long
Dim i As Integer
i = 5
'Other steps:
'1 - need to pick up variable (directory of files listed, taken from first macro
'when doing manually, I opened command, went to correct directory, then pasted
'the commands. I'm trying to handle pasting the commands. I'm not sure if I need
'something to open CMD from VBA, then run through the below loop, or add opening
'CMD and going to the directory in each iteration of the below loop...
'2 - Need to say - Loop below text if Worksheets("Batch Rename of Files").Cells(i, "C").Value is no blank
CommandString = Worksheets("Batch Rename of Files").Cells(i, "F").Value
Call Shell("cmd.exe /S /K" & CommandString, vbNormalFocus)
'Other steps:
'3 - need to increase i by 1
'4 - need to check if C column is blank or not
'5 - need to end of C column is blank
End Sub
Background:
I'm creating a file renaming tool for a friend. They can use excel, but no programming languages or command prompt. Because of this, I don't want to have any steps, like creating a batch file suggested here, that would complicate things for my friend.
I've created an excel file with:
Tab 1 - a template sheet to create a new file name list. Works by concatenating several cells, adding a filetype, and outputting to a range of cells. Tab two links to this range when creating the renaming command strings for CMD
Tab 2 -
Button 1 - Sub rename() below. VBA to list files in a selected directory in Column C
Column F creates a command line that will rename File A as File B based on inputs to Tab 1 i.e. ren "File 1" "A1_B1_C1.xlsx"
Button 2 - Refers to a renaming macro (requirement 1 and 2 above) that picks up the selected directory from Button 1 and runs through all the renaming command strings while in that directory
Sub rename()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
Worksheets("Batch Rename of Files").Activate
Worksheets("Batch Rename of Files").Range("C4").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
Caveats:
1) I am not entirely clear on how you data etc is laid out so i am offering a way of achieving your goal that involves the elements i am clear on.
2) To be honest, personally, i would do as much using arrays or a dictionary as possible rather than going backwards and forwards to worksheets.
However...
Following the outline of your requirements and a little rough and ready, we have:
1) Using your macro rename (renamed as ListFiles and with a few minor tweaks) to write the chosen folder name out to Range("A1") in Worksheets("Batch Rename of Files") and the file names to Column C.
2) Using a second macro RenameFiles to pick up the rename shell commands from Column F of Worksheets("Batch Rename of Files"); write these out to a batch file on the desktop; add an additional first line command that sets the working directory to the chosen folder given in Range("A1") (Requirement A). The shell command executes the .bat file, completes the renaming (Requirement B) and then there is a line to remove the .bat file.
I am guessing this is a more efficient way of achieving your goal than looping the column F range executing a command one at a time.
I have not sought to optimize code in any further ways (i have added a few existing typed functions.) There are a number of other improvements that could be made but this was intended to help you achieve your requirements.
Let me know how it goes!
Tab1 layout (Sheet containing new file names):
Batch Rename of Files layout (Sheet containing output of the first macro and the buttons ):
Layout of Worksheet Batch Rename of File
In a standard module called ListFiles:
Option Explicit
Public Sub ListFilesInDirectory()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$ 'type hints not really needed
Dim wb As Workbook
Dim wsTab2 As Worksheet
Set wb = ThisWorkbook
Set wsTab2 = wb.Worksheets("Batch Rename of Files")
InitialFoldr$ = "C:\"
Dim lastRow As Long
lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row
wsTab2.Range("C4:C" & lastRow).ClearContents 'Get rid of any existing file names
wsTab2.Range("C4").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
wsTab2.Range("A1") = xDirect$
Do While xFname$ <> vbNullString
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
In a standard module called FileRenaming:
Option Explicit
Sub RenameFiles()
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim strFile As String
Dim strPath As String
Dim strData As Range
Dim wb As Workbook
Dim wsTab2 As Worksheet
Dim currRow As Range
Set wb = ThisWorkbook
Set wsTab2 = wb.Worksheets("Batch Rename of Files")
strPath = wsTab2.Range("A1").Value2
If strPath = vbNullString Then
MsgBox "Please ensure that Worksheet Batch Rename of Files has a directory path in cell A1"
Else
If Right$(Trim$(strPath), 1) <> "\" Then strPath = strPath & "\"
strFile = "Rename.bat"
Dim testString As String
Dim deskTopPath As String
deskTopPath = Environ$("USERPROFILE") & "\Desktop" 'get desktop path as this is where .bat file will temporarily be saved
testString = fso.BuildPath(deskTopPath, strFile) 'Check if .bat already exists and delete
If Len(Dir(testString)) <> 0 Then
SetAttr testString, vbNormal
Kill testString
End If
Set stream = fso.CreateTextFile(deskTopPath & "\" & strFile, True) 'create the .bat file
Dim lastRow As Long
lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row
Set strData = wsTab2.Range("F4:F" & lastRow) 'Only execute for as many new file names as present in Col C (in place of your until blank requirement)
stream.Write "CD /D " & strPath & vbCrLf
For Each currRow In strData.Rows 'populate the .dat file
stream.Write currRow.Value & vbCrLf
Next currRow
stream.Close
Call Shell(testString, vbNormalFocus)
Application.Wait (Now + TimeValue("0:00:01")) 'As sometime re-naming doesn't seem to happen without a pause before removing .bat file
Kill testString
MsgBox ("Renaming Complete")
End If
End Sub
Buttons code in Worksheet Batch Rename of Files
Private Sub CommandButton1_Click()
ListFilesInDirectory
End Sub
Private Sub CommandButton2_Click()
RenameFiles
End Sub
Example .bat file contents:
VERSION 2
And here is a different version using a dictionary and passing parameters from one sub to another. This would therefore be a macro associated with only one button push operation i.e. there wouldn't be a second button. The single button would call ListFiles which in turn calls the second macro. May require you to go in to tools > references and add in Microsoft Scripting Runtime reference.
Assumes you have a matching number of new file names in Col D of tab 1 as the number of files found in the folder (as per your script to obtain files in folder). I have removed the obsolete type references.Shout out to the RubberDuck VBA add-in crew for the add-in picking these up.
In one standard module:
Option Explicit
Public Sub ListFiles()
Dim xDirect As String, xFname As String, InitialFoldr As String
Dim wb As Workbook
Dim ws As Worksheet
Dim dict As New Scripting.Dictionary
Dim counter As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Tab1") 'Worksheet where new file names are
counter = 4 'row where new file names start
InitialFoldr = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
.Show
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
xFname = Dir(xDirect, 7)
Do While xFname <> vbNullString
If Not dict.Exists(xFname) Then
dict.Add xFname, ws.Cells(counter, "D") 'Or which ever column holds new file names. This add to the dictionary the current name and new name
counter = counter + 1
xFname = Dir
End If
Loop
End If
End With
RenameFiles xDirect, dict 'pass directory path and dictionary to renaming sub
End Sub
In another standard module:
Public Sub RenameFiles(ByVal folderpath As String, ByRef dict As Dictionary)
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim strFile As String
Dim testString As String
Dim deskTopPath As String
strFile = "Rename.bat"
deskTopPath = Environ$("USERPROFILE") & "\Desktop"
testString = fso.BuildPath(deskTopPath, strFile)
'See if .dat file of same name already on desktop and delete (you could overwrite!)
If Len(Dir(testString)) <> 0 Then
SetAttr testString, vbNormal
Kill testString
End If
Set stream = fso.CreateTextFile(testString, True)
stream.Write "CD /D " & folderpath & vbCrLf
Dim key As Variant
For Each key In dict.Keys
stream.Write "Rename " & folderpath & key & " " & dict(key) & vbCrLf 'write out the command instructions to the .dat file
Next key
stream.Close
Call Shell(testString, vbNormalFocus)
Application.Wait (Now + TimeValue("0:00:01")) 'As sometime re-naming doesn't seem to happen without a pause before removing .bat file
Kill testString
' MsgBox ("Renaming Complete")
End Sub
Scripting run time reference:
Adding runtime reference
Additional method for finding the desktop path. Taken from Allen Wyatt:
In a standard module add the following:
Public Function GetDesktop() As String
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
End Function
Then in the rest of the code replace any instances of deskTopPath =..... e.g.:
deskTopPath = Environ$("USERPROFILE") & "\Desktop"
With
desktopPath = GetDesktop

VBA User Function Checking a Directory

Below is the code so far
I often times have to check if a Purchase Order has been saved in a directory, there could be hundreds of purchase orders listed in Excel.
As the Workbook changes, so often does the filepath.
As such, I would like to make a function that asks for a cell value that contains a string for the filepath, and then a a cell for the PO #.
I'm a little stumped on how best to past information from the Excel sheet. I need a cell reference for the filepath to the directory, and a cell reference for the PO #.
I've been able to make this work with a subroutine, that is what is posted below. This is the third VBA Program I've worked on, please let me know if there is more legwork I should do before posting this:
Dim directory As String
Dim TempfileName As String
Dim i As Long
Dim x As Long
Sub Check_PO()
x = 2
Application.ScreenUpdating = False
For x = 2 To 673
While Cells(x, 14) = 0
x = x + 1
Wend
i = Cells(x, 14)
TempfileName = "\\network\file\name\here\" & "*" & i & "*.pdf"
directory = Dir(TempfileName, vbNormal)
While directory <> ""
Cells(x, 18) = "Matched"
directory = Dir
Wend
Next x
End Sub
Here's a simple UDF:
Public Function HaveReport(fPath As String, fileName As String)
HaveReport = IIf(Dir(fPath & fileName, vbNormal) <> "", _
"Matched", "Not Matched")
End Function
Usage:

Exporting PowerPoint sections into separate files

Every week I separate a long PowerPoint file into separate files. The files must be in PowerPoint format, and contain only the slides that are contained in the 'sections' from the PowerPoint file.
I need to:
1) Scan to see the number of slides in a given section
2) Make a file containing the slides within that section
3) Name that file the same as the name of the section, and save it in the same directory as the source file.
4) Repeat the process for subsequent sections.
5) Do this without damaging the original file.
I've located code (http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm) that can break the file into many parts, but only by the number of files requested per file. I found some other helpful references here: http://skp.mvps.org/2010/ppt001.htm
I have coded in Basic and a number of easy gaming scripting languages. I need help understanding how this is done in VBA.
Since you do this very often, you should make an Add-In for this. The idea is to create copies of the presentation up to the number of sections in it, then open each one and delete the other sections and save.
Create blank presentation with macros enabled (*.pptm) and possibly add Custom UI button to call SplitIntoSectionFiles
Test and when satisfy, save as PowerPoint Add-In (*.ppam). Don't delete the pptm file!
Assuming that all are pptx files you are dealing with, you can use this code. It opens the splited pptx files in background, then remove irrelevant sections and save, close. If all goes well you get a message box.
Private Const PPT_EXT As String = ".pptx"
Sub SplitIntoSectionFiles()
On Error Resume Next
Dim aNewFiles() As Variant, sPath As String, i As Long
With ActivePresentation
sPath = .Path & "\"
For i = 1 To .SectionProperties.Count
ReDim Preserve aNewFiles(i)
' Store the Section Names
aNewFiles(i - 1) = .SectionProperties.Name(i)
' Force Save Copy as pptx format
.SaveCopyAs sPath & aNewFiles(i - 1), ppSaveAsOpenXMLPresentation
' Call Sub to Remove irrelevant sections
RemoveOtherSections sPath & aNewFiles(i - 1) & PPT_EXT
Next
If .SectionProperties.Count > 0 And Err.Number = 0 Then MsgBox "Successfully split " & .Name & " into " & UBound(aNewFiles) & " files."
End With
End Sub
Private Sub RemoveOtherSections(sPPT As String)
On Error Resume Next
Dim oPPT As Presentation, i As Long
Set oPPT = Presentations.Open(FileName:=sPPT, WithWindow:=msoFalse)
With oPPT
' Delete Sections from last to first
For i = .SectionProperties.Count To 1 Step -1
' Delete Sections that are not in the file name
If Not InStr(1, .Name, .SectionProperties.Name(i), vbTextCompare) = 1 Then
' Delete the Section, along with the slides associated with it
.SectionProperties.Delete i, True
End If
Next
.Save
.Close
End With
Set oPPT = Nothing
End Sub
Read about Custom UI if you don't have experience creating you own ribbon tab: msdn and use the "Office Custom UI Editor", I would use imageMso "CreateModule" for the button.
None of the proposed routines actually works, so I wrote mine from scratch:
Sub Split()
Dim original_pitch As Presentation
Set original_pitch = ActivePresentation
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With original_pitch
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
Dim i As Long
For i = 1 To original_pitch.SectionProperties.Count
Dim pitch_segment As Presentation
Set pitch_segment = Presentations.Open(Replace(original_pitch.FullName, "pptm", "pptx"))
section_name = pitch_segment.SectionProperties.Name(i)
For k = original_pitch.SectionProperties.Count To 1 Step -1
If pitch_segment.SectionProperties.Name(k) <> section_name Then pitch_segment.SectionProperties.Delete k, True
Next k
With pitch_segment
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, original_pitch.SectionProperties.Name(i) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Next i
MsgBox "Split completed successfully!"
End Sub
I could not get the above code to work.
However this is simpler and does work:
Sub SplitToSectionsByChen()
daname = ActivePresentation.Name
For i = 1 To ActivePresentation.SectionProperties.Count
For j = ActivePresentation.SectionProperties.Count To 1 Step -1
If i <> j Then ActivePresentation.SectionProperties.Delete j, True
Next j
ActivePresentation.SaveAs ActivePresentation.SectionProperties.Name(1)
ActivePresentation.Close
Presentations.Open (daname)
Next i
End Sub
I have edited fabios code a bit to look like this. And this works well for me in my PC
Option Explicit
Sub Split()
Dim original_File As Presentation
Dim File_Segment As Presentation
Dim File_name As String
Dim DupeName As String
Dim outputFname As String
Dim origName As String
Dim lIndex As Long
Dim K As Long
Dim pathSep As String
pathSep = ":"
#If Mac Then
pathSep = ":"
#Else
pathSep = "/"
#End If
Set original_File = ActivePresentation
DupeName = "TemporaryFile.pptx"
DupeName = original_File.Path & pathSep & DupeName
original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)
For lIndex = 1 To original_File.SectionProperties.Count
If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
File_name = File_Segment.SectionProperties.Name(lIndex)
For K = original_File.SectionProperties.Count To 1 Step -1
If File_Segment.SectionProperties.Name(K) <> File_name Then
Call File_Segment.SectionProperties.Delete(K, 1)
End If
Next K
outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")
With File_Segment
.SaveAs FileName:=.Path & outputFname & ".pptx", FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Set File_Segment = Nothing
End If
Next
Set original_File = Nothing
Kill DupeName
MsgBox "Split completed successfully!"
End Sub
This works for me (except for the filename):
Option Explicit
Sub ExportSlidesAsPresentations()
Dim oPres As Presentation
Dim sSlideOutputFolder As String
Set oPres = ActivePresentation
sSlideOutputFolder = oPres.Path & "\"
'Export all the slides in the presentation
Call oPres.PublishSlides(sSlideOutputFolder, True, True)
Set oPres = Nothing
End Sub