PPT의 표(테이블)를 엑셀시트에 일괄 복사

VBA 처리과정도

마우스로 슬라이드의 표(테이블)을 복사해서 엑셀 시트에 붙여넣는 것과 유사합니다.

​

테이블.Copy 해서 시트의 셀.Paste 하거나 시트.PasteSpecial로 붙여넣습니다.

​

테이블이 여러개 일텐데  아래와 같은 샘플을 만들었습니다.

​

VBA코드:

'Copy the table content on each slide to Excel sheet

Option Explicit

Const TextOnly As Boolean = False

Sub CopyTableToSheet()
    Dim xl As Object    'New Excel.Application
    Dim wb As Object    'Excel.Workbook
    Dim sht As Object   'Excel.Worksheet
    Dim rng As Object   'Excel.Range
    
    Set xl = CreateObject("Excel.Application")
    xl.Visible = True
    Set wb = xl.Workbooks.Add
    Set sht = wb.Worksheets(1)
    
    Dim pres As Presentation
    Dim sld As Slide
    Dim shp As Shape
    
    Set pres = ActivePresentation
    'pres.Save
    
    Set rng = sht.Range("A1")
    
    For Each sld In pres.Slides
    
        For Each shp In sld.Shapes
        
            If shp.Type = msoTable Then
                
                shp.Copy    '테이블(표) 복사
                
                If TextOnly Then
                    rng.Select
                    sht.PasteSpecial Format:="HTML", NoHTMLFormatting:=True
                Else
                    sht.Paste rng '복사한 테이블 붙여넣기
                End If
                
                Set rng = rng.Offset(shp.Table.Rows.Count) '다음 셀 위치
                
            End If
        
        Next shp
    
    Next sld
 
    Set xl = Nothing
    
End Sub

 

아래는 실행 영상입니다.

 

아래는 엑셀 결과물입니다.

왼쪽이 TextOnly = False 인 경우이고

오른쪽의 TextOnly = True인 경우입니다.

​

참고로 슬라이드의 표(테이블) 셀을 일일이 엑셀 시트의 셀에 복사하는 예제는 아래와 같습니다.

1슬라이드의 Table 1 이라는 표의 셀들을 엑셀 시트에 그대로 값만 복사합니다.

'테이블 셀을 일일이 시트의 셀에 복사
Sub CopyTableCell()

    Dim xl As Object    'New Excel.Application
    Dim wb As Object    'Excel.Workbook
    Dim sht As Object   'Excel.Worksheet
    Dim rng As Object   'Excel.Range
    
    Set xl = CreateObject("Excel.Application")
    xl.Visible = True
    Set wb = xl.Workbooks.Add
    Set sht = wb.Worksheets(1)
    
    Dim pres As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Dim r As Integer, c As Integer
    
    Set pres = ActivePresentation
    With pres.Slides(1).Shapes("Table 1").Table
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                sht.Cells(r, c) = .Cell(r, c).Shape.TextFrame.TextRange.Text
            Next c
        Next r
    End With
    
    Set xl = Nothing
End Sub

 

pptm 파일 첨부합니다.

Table2Excel1.pptm

0.05MB

 

​

참고: ppt 테이블과 엑셀 차트 연동 예제

https://konahn.tistory.com/entry/UpdateChart

슬라이드의 테이블(표)과 차트의 데이터 연동시키기

 

참고: 테이블 일부만 복사하는 경우

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=463335962&page=1#answer1

Table2Excel2.pptm

0.05MB

 

'Copy the table content on each slide to Excel sheet

Option Explicit

Const TextOnly As Boolean = False

Sub CopyTableToSheet()
    Dim xl As Object    'New Excel.Application
    Dim wb As Object    'Excel.Workbook
    Dim sht As Object   'Excel.Worksheet
    Dim rng As Object   'Excel.Range
    Dim r%, c%, rc%, cc%, rt%, ct%, t%
    
    '2행 2열까지만 복사하는 경우
    rc = 2: cc = 2
    
    Set xl = CreateObject("Excel.Application")
    xl.Visible = True
    Set wb = xl.Workbooks.Add
    Set sht = wb.Worksheets(1)
    
    Dim pres As Presentation
    Dim sld As Slide
    Dim shp As Shape
    
    Set pres = ActivePresentation
    'pres.Save
    
    Set rng = sht.Range("A1")
    
    For Each sld In pres.Slides
    
        For Each shp In sld.Shapes
        
            If shp.Type = msoTable Then
                
                shp.Copy    '테이블(표) 복사
                
                If TextOnly Then
                    rng.Select
                    'sht.PasteSpecial Format:="HTML", NoHTMLFormatting:=True
                    With shp.Table
                        For r = 1 To rc '2행까지
                            For c = 1 To cc '2열까지
                                rng.Offset(r - 1, c - 1) = .Cell(r, c).Shape.TextFrame.TextRange.Text
                            Next c
                        Next r
                    End With
                Else
                    sht.Paste rng '복사한 테이블 붙여넣기
                    rt = shp.Table.Rows.Count       '행수
                    ct = shp.Table.Columns.Count    '열수
                    For t = rc To rt    '2행이후 삭제
                        rng.Offset(rc).EntireRow.Delete
                    Next t
                    For t = cc To ct    '2열 이후 삭제
                        rng.Offset(, cc).EntireColumn.Delete
                    Next t
                End If
                
                'Set rng = rng.Offset(shp.Table.Rows.Count) '다음 셀 위치
                Set rng = rng.Offset(rc)
                
            End If
        
        Next shp
    
    Next sld
 
    Set xl = Nothing
    
End Sub