엑셀 각 시트를 10행씩 끊어서 파워포인트 각 슬라이드에 붙여넣기

일단 아래와 같은 엑셀 시트(통합 문서1.xlsx)가 있습니다.

 

위에서 원하는 행만큼(여기서는 10행씩) 분할해서(끊어서) 파워포인트 각 슬라이드에 옮기는 작업입니다.(아래 그림)

Const xlFile As String = "통합 문서1.xlsx"
Const xlLines As Integer = 10   '10이면 엑셀 데이터를 10줄씩 분할 복사
Const Margin As Single = 100     '슬라이드의 여백

Sub Sheet2Slide()
    
    Dim XL As Object
    Dim Sht As Object
    Dim rng0 As Object, rng As Object
    Dim Pres As Presentation
    Dim Sld As Slide
    Dim Shp As Shape
    Dim SW!, SH!
    
    Set Pres = ActivePresentation
    SW = Pres.PageSetup.SlideWidth: SH = Pres.PageSetup.SlideHeight
    Set XL = CreateObject("Excel.Application")
    
    For Each Sht In XL.Workbooks.Open(Pres.Path & "\" & xlFile).worksheets
    
        Set rng0 = Sht.UsedRange
        Set rng = rng0
        While Not rng0 Is Nothing
            '10줄씩 복사 붙여넣기
            Set rng = rng0.Resize(xlLines)
            rng.Copy
            
            Set Sld = Pres.Slides.Add(Pres.Slides.Count + 1, ppLayoutBlank)
            Set Shp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, SW, 50)
            Shp.TextFrame.TextRange = Sht.Name & "_" & rng.Address
            Set Shp = Sld.Shapes.PasteSpecial(ppPasteOLEObject)(1)
            '크기 조정
            Shp.LockAspectRatio = msoFalse
            Shp.Width = SW - Margin * 2
            Shp.Height = SH - Margin * 2
            Shp.Left = Margin: Shp.Top = SH / 2 - Shp.Height / 2
            Shp.Name = Sht.Name & "_" & rng.Address
            '남은 범위 계산
            Set rng0 = DisUnion(XL, rng0, rng)
        Wend
            
    Next Sht
    XL.CutCopyMode = False 'Clear Clipboard
    XL.Quit
    Set XL = Nothing

End Sub

Public Function DisUnion(App As Object, Keep As Object, Remove As Object) As Object

    Dim Rng_output As Object

    Dim Cell As Object
    For Each Cell In Keep

        'check if given cell is in range to remove
        If App.Intersect(Cell, Remove) Is Nothing Then

            'this builds the output and handles first case
            If Rng_output Is Nothing Then
                Set Rng_output = Cell
            Else
                Set Rng_output = App.Union(Rng_output, Cell)
            End If
        End If
    Next Cell

    Set DisUnion = Rng_output

End Function

특히 엑셀 영역을 빼는 사용자 함수(UDF)를 추가하여 총 범위에서 10행식 빼나가면서

각슬라이드에 붙여넣게 만들었습니다.

 

붙여넣을 때 그림으로 붙여넣을 수도 있는데 엑셀개체로 붙여넣도록 했습니다. (편집 가능)

회색줄도 출력되는데 이것을 피하려면 먼저 엑셀에서 흰색 선으로 바꾸어 놓으세요.

 

여백이 있고 세로로 좀 늘어나는데 이것은 소스를 수정하면 되겠습니다.

 

통합 문서1.xlsx

0.02MB

Sheet2Slide1.pptm

0.33MB

 

(지식인 링크)

 

추가: 엑셀 각시트의 프린트 영역을 파워포인트 슬라이드에 각각 복사하는 버전(엑셀 매크로)

(지식인 링크)

Sheet2Slide1.xlsm

0.03MB