I am trying to Use VBA to create a compiler. It will take user input of a string and look for folders, within a folder, containing that string, enter the folder and copy the .xl* file from in there to a folder that I create.
Sub outputsCompiler()
Call GetFolder
If Cells(1, 1) = 0 Then
Exit Sub
End If
Call compileoutputsPrompt
If Cells(1, 2) = 0 Then
Exit Sub
End If
Dim i As Integer
' Dim ResultsFile
'
' Set FSO = CreateObject("scripting.filesystemobject")
For i = 2 To 9
If (Cells(1, i) <> Empty) Then
'
' ResultsFile = Dir(Cells(1, 1) & "*" & Cells(1, i) & "*.xl*")
' Cells(3, 5) = ResultsFile
MkDir (Cells(1, 1) & "CompiledOutputs" & Cells(1, i))
' DestFolder = Cells(1, 1) & "CompiledOutputs" & Cells(1, i)
'FSO.CopyFile Source:=ResultsFile Destination:=DestFolder
End If
Next i
End Sub
Everything in this code works, except the things I have commented out. Also all of the Subs I call work fine. The strings I am searching for will be pasted in Row 1 Columns 2-9 and The folder containing all other folders, including the folder I will create is in Cells(1,1).
Related
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
Thanks for any help you can provide. I have managed using a macro to search through folders and sub folders and hyperlink them and display Folder 1 in column A the files that is in the folder in column B.
There is about 200 folders and some 1600 files. Anyway I want to be able to place a button and attach a macro to that button that will enable only the folder and files names be to copy from that buttons position.
I was thinking of placing that button in column D directly across from the folder name in column A
The code does something similar to what you appear to want. It recursively (see TraversePath subroutine) finds all the paths and files in them and prints them out to "Sheet1" in the same manner as the image you posted with your question: the file folder names are written out to column 'A' (as a hyperlink), the files in that folder are written out to column 'B' (again as hyperlinks) and a button is placed in column 'C'.
Modify 'CreateDirSheet' with the root or top directory for which you want all sub-folders and files printed out in 'Sheet1'. The '1' argument to 'TraversePath' is the row # of where to start printing out the folders/files in 'Sheet'.
The TraversePath subroutine places the buttons and identifies the macro handler that is processed when the button is pressed. Two arguments are passed to that routine: the name of the sheet (it'll be 'Sheet1' in this case) and the row number from where the folder is given in column 'A'.
When a button is pressed the handler prompts the user for the destination path and goes down the list in column 'B' copying all the files from the source folder (in column 'A') to the destination folder provided by the user.
It's probably not entirely what you're after but should be a good starting point to get the functionality you want.
Option Explicit
' Button event handler
Sub CopyDirBtn(shtName As String, rs As String)
Dim sht As Worksheet
Set sht = Worksheets(shtName)
' Get the destination path (where to copy files) from user
Dim dpath As String, spath As String
Dim fdialog As FileDialog
Set fdialog = Application.FileDialog(msoFileDialogFolderPicker)
With fdialog
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> 0 Then
dpath = .SelectedItems(1)
Else
Exit Sub
End If
End With
' Copy all files
Dim r As Integer: r = CInt(rs)
With sht
spath = .Cells(r, "A")
r = r + 1
Do While .Cells(r, "B") <> ""
FileCopy spath & .Cells(r, "B"), dpath & "\" & .Cells(r, "B")
r = r + 1
Loop
End With
End Sub
' Populate sheet with folder/link links and buttons
Sub TraversePath(path As String, r As Integer)
Dim currentPath As String, directory As Variant
Dim dirCollection As Collection
Set dirCollection = New Collection
currentPath = Dir(path, vbDirectory)
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
With sht
'Add directory and hyperlink to sheet
.Hyperlinks.Add Anchor:=.Cells(r, "A"), _
Address:=path, _
TextToDisplay:=path
' Add copy button
Dim copyBtn As Button
Set copyBtn = .Buttons.Add(Cells(r, "C").Left, _
Cells(r, "C").Top, 100#, 14#)
With copyBtn
.Caption = "Copy Files"
.Name = "copyBtn_" & r
.Locked = False
.OnAction = "'CopyDirBtn """ & sht.Name & """, """ & r & """'"
End With
' Add files and hyperlinks to sheet
r = r + 1
Do Until currentPath = vbNullString
If Left(currentPath, 1) <> "." And _
(GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
dirCollection.Add currentPath
Else
If currentPath <> "." And currentPath <> ".." Then
.Hyperlinks.Add Anchor:=.Cells(r, "B"), _
Address:=path, _
TextToDisplay:=currentPath
r = r + 1
End If
End If
currentPath = Dir()
Loop
End With
'process remaining directories
For Each directory In dirCollection
TraversePath path & directory & "\", r
Next directory
End Sub
' This is the main macro that populates the sheet
' Modify first parameter so it's your root folder path
Sub CreateDirSheet()
TraversePath "D:\tmp\", 1
End Sub
I hope you can help I have a piece of code and what it does is it takes information from two excel sheets and puts it into two text docs for consumption in a database.
The code I have works fine but 22 columns have been added in the database where the text file is destined to be consumed so I need to put 22 pipes(|) before company Id in Notepad file
The first pic is of the Excel sheet where staff can input data
The second pic shows the excel sheet where the data is sorted from the 'Meeting Close Out Template' and the macro picks up the data for transformation to text. This sorting sheet is called 'Template-EFPIA-iTOV' the columns in grey are what the macro pics up
In the below pic you can see that Company Id is the last column in 'Template-EFPIA-iTOV
Below is how the sheet 'Template-EFPIA-iTOV ' is represented in text
Here is the Company IDs in the Text file
Because the destination database has now got an extra 22 columns before Company Id I need my macro to put 22 pipes(|) before Company id in the text doc.
The Excel sheet 'Template EFPIA Customer' is also converetd to text but this is fine and needs no amendments.
My Code is below. As always any help is greatly appreciated.
Pic of Macro front end
CODE
'Variables for Deduplication
Dim WB_Cust As Workbook
'File Variables
Dim DTOV_Directory As String
Dim DTOV_File As String
Dim ITOV_Directory As String
Dim ITOV_file As String
Const DELIMITER As String = "|"
' Variables for writing text into file
Dim WriteObject As Object
Dim OUTFilename As String
Dim MyWkBook As Workbook
Dim MyWkSheet As Worksheet
Dim OutputFile As String ' Output flat file name
Dim SysCode As String ' Variable for text string of system code to be filled into information system code column
Dim strFilenameOut As String ' Variable for name of file being processed. It is used for SysCode and OutputFile determination.
Dim CustAddressSave As Range
'Processing of one file. This procedure is called when only one of file types are selected
Public Sub Process_template(Directory As String, File As String, FileFlag As String)
Application.ScreenUpdating = False 'Turns off switching of windows
If FileFlag = "D" Then 'Variables setup for DTOV
DTOV_Directory = Directory
DTOV_File = File
ElseIf FileFlag = "I" Then 'Variables setup for ITOV
ITOV_Directory = Directory
ITOV_file = File
Else
MsgBox "Unhandled Exception - Unknown files sent"
Exit Sub
End If
Call Process(1, FileFlag)
Application.ScreenUpdating = True 'Turns On switching of windows
End Sub
'Processing of two file. This procedure is called when both file types are to be processed
Public Sub Process_Templates(DTOV_Dir As String, DTOV_Fil As String, ITOV_Dir As String, ITOV_Fil As String)
Application.ScreenUpdating = False 'Turns off switching of windows
DTOV_Directory = DTOV_Dir
DTOV_File = DTOV_Fil
ITOV_Directory = ITOV_Dir
ITOV_file = ITOV_Fil
Call Process(2, "B")
Application.ScreenUpdating = True 'Turns on switching of windows
End Sub
' *****************************************************************************
' Management of File to write in UT8 format
' *****************************************************************************
' This function open the file indicated to be able to write inside
Private Sub OUTFILE_OPEN(filename As String)
Set WriteObject = CreateObject("ADODB.Stream")
WriteObject.Type = 2 'Specify stream type - we want To save text/string data.
WriteObject.Charset = "utf-8" 'Specify charset For the source text data.
WriteObject.Open 'Open the stream And write binary data To the object
OUTFilename = filename
End Sub
' This function closes the file
Private Sub OUTFILE_CLOSE()
WriteObject.SaveToFile OUTFilename, 2
WriteObject.Close ' Close the file
End Sub
' Write a string in the outfile
Private Sub OUTFILE_WRITELINE(txt As String)
WriteObject.WriteText txt & Chr(13) & Chr(10)
txt = ""
End Sub
' subprocedure to read TOV data into stream and call procedure to generate file
Public Sub generate_tov(i_Sheet_To_Process As String, _
i_OffsetShift As Integer)
Dim sOut As String ' text to be written into file
'Set OutputFile = "sarin"
Sheets(i_Sheet_To_Process).Select
Range("C2").Select
'Parsing of system code from filename
strFilenameOut = ActiveWorkbook.Name 'example - initial file name: EFPIA_DTOV-BE-MTOV-201503271324.xlsx
SysCode = Left(strFilenameOut, InStrRev(strFilenameOut, "-") - 1) 'example - after LEFT cut EFPIA_ITOV-BE-MTOV
SysCode = Right(SysCode, Len(SysCode) - InStrRev(SysCode, "-")) 'example - after RIGHT cut MTOV
Do Until (IsError(ActiveCell.Offset(0, 1).Value) = True)
If ActiveCell.Offset(0, 1).Value = "" Then
'end-of-file reached, hence exist the do loop
Exit Do
End If
ActiveCell.Value = SysCode
ActiveCell.Offset(0, i_OffsetShift).Value = Application.WorksheetFunction.VLookup(Sheets("Template - EFPIA Customer").Cells(ActiveCell.Row, 3).Value, Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, i_OffsetShift).Value
ActiveCell.Offset(1, 0).Select
Loop
OutputFile = Left(strFilenameOut, InStrRev(strFilenameOut, ".") - 1) & ".txt"
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
MsgBox ("incorrect data in the TOV source file. Please correct and re-run the macro")
Exit Sub
Else
Call generate_file
End If
End Sub
' procedures to write stream data into file for both TOV and customer
Public Sub generate_file()
Dim X As Integer
Dim Y As Long
Dim FieldValue As String
Dim NBCol As Integer
Dim sOut As String ' text to be written into file
OUTFILE_OPEN (OutputFile) 'Open (setup) the output file
'Open OutputFile For Output As #1 'Prepares new file for output
Set MyWkBook = ActiveWorkbook
Set MyWkSheet = ActiveSheet
NBCol = 0
Do While (Trim(MyWkSheet.Cells(1, NBCol + 1)) <> "")
NBCol = NBCol + 1
Loop
' Scroll all rows
Y = 1
Do While (Trim(MyWkSheet.Cells(Y, 4)) <> "")
sOut = ""
For X = 1 To NBCol
' here, if required, insert a convertion type function
FieldValue = Trim(MyWkSheet.Cells(Y, X))
FieldValue = Replace(FieldValue, "|", "/") 'Replaces pipes from input file to slashes to avoid mismatches during ETL
If FieldValue = "0" Then FieldValue = "" 'Replaces "only zeroes" - might need redoing only for amount columns
If InStr(MyWkSheet.Cells(1, X), "Amount") > 0 Then FieldValue = Replace(FieldValue, ",", ".")
' add into the string
If X = NBCol Then
sOut = sOut & FieldValue
Else
sOut = sOut & FieldValue & DELIMITER
End If
Next X
Y = Y + 1
OUTFILE_WRITELINE sOut
Loop
OUTFILE_CLOSE
End Sub
' read the customer data into stream
Public Sub read_customer(i_Sheet_To_Process As String, _
i_range As String)
Dim CCST As Workbook ' Variable to keep reference for template Workbook that is being used for copy-paste of Customer data into virtuall Workbook
Sheets(i_Sheet_To_Process).Select
ActiveSheet.UsedRange.Copy
Set CCST = ActiveWorkbook
WB_Cust.Activate
If i_range = "" Then
Sheets("Sheet1").Range(CustAddressSave.Address).PasteSpecial xlPasteValues
Range(CustAddressSave.Address).Select
ActiveCell.Offset(0, 2).Select
Rows(CustAddressSave.Row).EntireRow.Delete
Else
Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
Range("C2").Select
End If
'Call LookingUp(CCST)
Do Until (IsError(ActiveCell.Offset(0, 1).Value) = True)
If ActiveCell.Offset(0, 1).Value = "" Then
'end-of-file reached, hence exist the do loop
Exit Do
End If
ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, 0).Value, CCST.Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, 1).Value
ActiveCell.Value = SysCode
ActiveCell.Offset(1, 0).Select
Loop
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
MsgBox ("incorrect data in the source file. Please correct and re-run the macro")
Exit Sub
Else
Set CustAddressSave = ActiveCell.Offset(0, -2) 'Saves position where 2nd Cust data sheet will be copied
OutputFile = Left(Mid(strFilenameOut, 1, (InStr(strFilenameOut, "_"))) & "CUST" & Mid(strFilenameOut, (InStr(strFilenameOut, "-"))), InStrRev(strFilenameOut, ".") - 1) & ".txt"
End If
End Sub
'Main Procedure of the module that processes the files
Private Sub Process(Loops As Integer, FileFlag As String) 'Loops - number of files (1 or 2), FileFlag - which file is to be processed (I - ITOV, D - DTOV, B - Both)
Set WB_Cust = Workbooks.Add
' This virtual workbook is created only for duration of the processing. It is used to copy paste CUSTOMER data form one or both templates.
If FileFlag = "D" Or FileFlag = "B" Then
' process DTOV first always
Call Open_DTOV
'----------------------------------------------------------
Call generate_tov("Template - Transfer of Value", 3)
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
'----------------------------------------------------------
Call read_customer("Template - EFPIA Customer", "A")
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
End If
If FileFlag = "I" Or FileFlag = "B" Then
Call Open_ITOV
'----------------------------------------------------------
Call generate_tov("Template - EFPIA iToV", 17)
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
'----------------------------------------------------------
If FileFlag = "B" Then
Call read_customer("Template - EFPIA Customer", "")
Else
Call read_customer("Template - EFPIA Customer", "A")
End If
' if the file have data issues, then abort the procedure.
If (IsError(ActiveCell.Offset(0, 1).Value) = True) Then
GoTo HandleException
End If
End If
Call Deduplicate
Call generate_file ' generate single customer file
MsgBox "Export Process is completed"
HandleException:
' Closes the virtual workbook used for consolidation and deduplication of customers
WB_Cust.Saved = True
WB_Cust.Close
ActiveWorkbook.Saved = True 'Closes Template
ActiveWorkbook.Close (False)
If Loops = 2 Then 'Closes second Template if two files are being processed
ActiveWorkbook.Saved = True
ActiveWorkbook.Close (False)
End If
Application.ScreenUpdating = True 'Turns back on switching to exported excel file once it gets opened
Exit Sub
End Sub
'Unused Procedure to reduce Customer data processing code. Does not work now.
Private Sub LookingUp(CCST As Workbook)
Do Until (ActiveCell.Offset(0, 1).Value = "")
ActiveCell.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, 0).Value, CCST.Sheets("Appendix").Range("N1:O103"), 2, "FALSE") & "_" & ActiveCell.Offset(0, 1).Value
ActiveCell.Value = SysCode
ActiveCell.Offset(1, 0).Select
Loop
End Sub
'Open DTOV Template
Private Sub Open_DTOV()
Workbooks.Open (DTOV_Directory + DTOV_File)
End Sub
'Open ITOV Template
Private Sub Open_ITOV()
Workbooks.Open (ITOV_Directory + ITOV_file)
End Sub
'Deduplicating Customer data based on Source_Party_Identifier, which already contains source code prefix
Private Sub Deduplicate()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=4, Header:=xlYeas
End Sub
Since your code is set up to detect the number of columns using this section of generate_file:
Do While (Trim(MyWkSheet.Cells(1, NBCol + 1)) <> "")
NBCol = NBCol + 1
Loop
...and then dynamically saves all the rows to the pipe delimited text file, I strongly recommend just adding the new columns into your sheet, even if they are going to be blank.
However, if you want to jury-rig it to get the job done, you can always add 22 pipes to each output row. Replace OUTFILE_WRITELINE sOut in the generate_file loop with OUTFILE_WRITELINE "||||||||||||||||||||||" & sOut.
Make sure, if you do decide to use that ugly hack, that you comment it very carefully so that you and any other maintainers of the code can find and fix it when the requirements inevitably change again.
I'm trying to create a macro that reads each *.txt file from a folder, and if the modification date matches the current one, copy the contents into a worksheet of the *.xls file. I've been checking a lot of the codes you have been sharing here, but I just can't make it work.
When debbuging, at the 8th line, I get an error:
438: Object doesn't support this property or method
Sub GetSAPfiles()
Dim Cont As Integer
Dim RootDir As String
RootDir = "\HOME\SAP\dir\"
SAPfile = Dir(RootDir)
Set SAPfile = CreateObject("Scripting.FileSystemObject")
Set SF = SAPfile.GetFile(RootDir + SAPfile)
Do While SAPfile <> ""
Dim ObjDate, CurrDate
CurrDate = Format(Now(), "MM/DD/YYYY")
ObjDate = Format(file.DateLastModified, "MM/DD/YYYY")
If CurrDate = ObjDate Then
Cont = Cont + 1
Dim TxtFl, Txt
Set TxtFl = SAPfile.OpenTextFile(RootDir + SAPfile)
Txt = TxtFl.ReadLine
ActiveSheet.Cells(Cont, "A").Value = Txt
ArchTxt.Close
End If
SAPfile = Dir(RootDir)
Loop
End Sub
Try something like this instead, use the command prompt to get an array of files and loop through them using the FSO to check the modified date and read the text into the next blank cell in column A:
Sub SO()
RootDir$ = "\HOME\SAP\dir\"
For Each x In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR " & RootDir & "*.* /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
With CreateObject("Scripting.FileSystemObject")
If DateValue(.GetFile(RootDir & x).DateLastModified) = Date Then _
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = .OpenTextFile(RootDir & x, 1).ReadAll
End With
Next x
End Sub
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