PPT 합치기

PPT를 합치는 방법은 다양한 방법이 있습니다.

 

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=430910486&sc%20https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=430910486&scrollTo=answer1 

 

 

VBA로 파일이나 폴더를 선택해서 새로운 프리젠테이션 파일에

합쳐주는 방법입니다.

 

좀 더 단순한 방법은,

( 매크로가 들어있는 첨부한 pptm파일을 만들어 놓고 필요할 때 이 파일을 열고 Alt-F8을 누른 다음

매크로 둘 중 하나를 선택하는 것입니다. )

매크로가 들어있는 첨부한 pptm 파일을 (차단해제 후) 열면 매크로 선택창이 자동으로 뜨는데 아래 둘 중 하나를 선택하세요.

​

※insertAllFiles: 선택한 폴더 내의 모든 ppt 파일을 파일명 순서대로 합치기

(폴더를 선택할 때 파일 선택하듯이 하지 말고 원하는 폴더 안으로 들어간 다음 '현재 폴더 선택'버튼을 누르세요.)

※insertSelectedFiles: 선택한 파일들만 파일명 순서대로 합치기

​

선택 후 해당 폴더나 파일들을 선택하면 새로운 파일에 ppt파일들을 모두 합쳐줍니다.

​

Option Explicit

Sub onLoad(UI As Variant)

    'Windows(1).Activate
    'SendKeys "%{F8}", True
    'Application.Dialogs(xlDialogRun).Show
    CommandBars.ExecuteMso ("MacroPlay")
    DoEvents
    SendKeys "{TAB}{TAB}"
    
End Sub

'선택한 파일만 파일명 순서대로 합치기
Sub InsertSelectedFiles()
'  Insert all slides from all presentations in the same folder as this one
'  INTO this one; do not attempt to insert THIS file into itself, though.

    Dim pres As Presentation, nPres As Presentation
    Dim vArray() As String
    Dim x As Long

    Set pres = ActivePresentation
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "합칠 ppt 파일들을 순서대로 선택하세요."
        .Filters.Clear
        .Filters.Add "PPT파일", "*.ppt?"
        .InitialFileName = pres.Path & "\"
        If .Show = -1 Then
            If .SelectedItems.Count = 0 Then Exit Sub
            
            Set nPres = Presentations.Add(msoTrue)
            For x = 1 To .SelectedItems.Count
                nPres.Slides.InsertFromFile .SelectedItems(x), nPres.Slides.Count
                Debug.Print x, .SelectedItems(x)
            Next
        End If
    End With

End Sub

'선택 폴더의 모든 파일 파일명 순으로 합치기
Sub InsertAllSlides()
'  Insert all slides from all presentations in the same folder as this one
'  INTO this one; do not attempt to insert THIS file into itself, though.

    Dim vArray() As String
    Dim x As Long
    Dim pres As Presentation, nPres As Presentation
    
    Set pres = ActivePresentation
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "파일들이 있는 폴더로 들어가서 '현재 폴더 선택'버튼을 누르세요."
        .InitialFileName = pres.Path & "\"
        .ButtonName = "현재 폴더 선택"
        If .Show = -1 Then
            ' Change "*.PPT" to "*.PPTX" or whatever if necessary:
            EnumerateFiles .SelectedItems(1) & "\", "*.PPT?", vArray
            
            Set nPres = Presentations.Add(msoTrue)
            With nPres
                For x = 1 To UBound(vArray)
                    If Len(vArray(x)) > 0 Then
                        .Slides.InsertFromFile vArray(x), .Slides.Count
                        Debug.Print x, vArray(x)
                    End If
                Next
            End With
        End If
    End With
End Sub

Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef vArray As Variant)
    ' collect all files matching the file spec into vArray, an array of strings

    Dim sTemp As String
    ReDim vArray(1 To 1)

    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        ' NOT the "mother ship" ... current presentation
        If sTemp <> ActivePresentation.Name Then
            ReDim Preserve vArray(1 To UBound(vArray) + 1)
            vArray(UBound(vArray)) = sDirectory & sTemp
        End If
        sTemp = Dir$
    Loop

End Sub

 

pptm 파일을 열 필요도 없이 바로 실행하려면

리본메뉴UI를 추가하고 추가기능으로 만들어서 아무때나 실행할 수 있게 만들 수도 있습니다.

 

참고:

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=430989190 

 

첨부파일은 다운로드 후 파일 속성에서 '차단해제' 체크하고 적용/확인 후에 열면 됩니다.

 

 

PPT합치기1.pptm

0.31MB