Create PDF bookmarks while combinding files with VBA in Excel

[dchaney]

Hello all,

I currently have multiple folders with PDF files in them, I have found and tweaked the following code to combine the PDF files within each folder into a single document (which is what I need it to do). However, what I can not figure out is how to add Bookmarks for each new file added, please review the below code and help if possible. I am a novice at best on VBA coding and teaching myself as I go.

Sub MoveFiles() 'Designed to move files in a folder based on the information in an excel file (BP R05 - L01 Material Certs)
'
'-------------------------------------------------------------------------------
'Must have an Excel spredsheet with the following headers on Row 8: A8 = PES Group, B8 = Part Number, C8 = Keyword, D8 = Subtitle, F8 = Serial No., G8 = Doc. No., I8 = Pages
'Important columns are B, F, G and I
'Each parent row must be shaded grey (ColorIndex 15) which is the 4th grey from the bottom of the fill color table
'-------------------------------------------------------------------------------
'
Dim FromPath As String, ToPath As String, FolderName As String, FileName As String
Dim lastRow As Long
Dim FSO As Object

'Turn off Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
On Error Resume Next

Set FSO = CreateObject("scripting.filesystemobject")

'Select the folder that stores the files you wish to move
Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    DialogFolder.InitialFileName = ActiveWorkbook.Path
    If DialogFolder.Show = -1 Then
        FromPath = DialogFolder.SelectedItems(1) & "\"
    Else: Set DialogFolder = Nothing
    End If
    
Set DialogFolder = Nothing

lastRow = Range("A" & Rows.Count).End(xlUp).Row

'Move files into folders per information found on excel spread sheet as listed above
i = 9

Do Until i > lastRow

FolderName = i - 8 & " - " & Cells(i, 2) & " - " & Cells(i, 6) & "\" 'sets the foldername inwhich the files will be moved to
ToPath = FromPath & FolderName 'Set the path to move the files to
FileName = Cells(i, 7) & "_REV000.pdf" 'name of the file to move into the ToPath location

'Cells(1, 15) = FromPath

If Cells(i, 1).Interior.ColorIndex = 15 Then
        ParentFolder = i - 8 & " - " & Cells(i, 2) & " - " & Cells(i, 6) & "\" 'create the value for the ParentFolder
        FSO.MoveFile Source:=FromPath & FileName, Destination:=FromPath & ParentFolder 'move the Parent File into the ParentFolder
    i = i + 1
ElseIf Cells(i, 1).Interior.ColorIndex <> 15 Then
        FSO.CopyFile Source:=FromPath & FileName, Destination:=FromPath & ParentFolder
    i = i + 1
End If

Loop

Set FSO = Nothing

Kill FromPath & "*.pdf" 'Deletes all pdf files that remain on the FromPath directory

MsgBox "All files have been moved, you may go about your merry day :)"

'Turn on Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub

 

[ankurc_dk]

The code doesn't seem to perform any action. Can someone attach the .xlsm file or share the working code?
Thanks in advance