표안의 셀들을 도형으로 변환, 각각 애니메이션 적용하기

관련 지식인 링크

 

표 안의 셀들도 Shape의 일종이지만

다른 도형들처럼 자유롭게 모든 기능을 지원하지는 않습니다.

서식복사 기능도 지원하지 않고 애니메이션도 따로 적용할 수 없습니다.

​

하나의 방법으로 VBA를 이용해서

셀들의 내용을 복사해서 일반 도형으로 만드는 방법이 있겠습니다.

첨부파일을 다운받아 매크로를 허용해서 여세요.

 

그리고 사용자의 파일을 열고

원하는 셀들을 선택한 상태에서

개발도구-매크로를 누르거나 Alt-F8을 누르고 나서

매크로 선택창이 뜨면 먼저 아래의 매크로위치를 미리 열어둔 pptm파일로 선택하면

Cell2Shape 매크로를 실행할 수 있습니다.

​

Alt-F8누르고 매크로 위치를 선택해서 Cell2Shape 매크로 실행

실행 결과 화면 - 셀들이 도형으로 변환되어 애니메이션 적용 가능

셀을 도형으로 비슷하게 복사는 하지만

완벽하게 동일하게는 복사가 안될 수 있습니다.

특히 제목셀 등의 속성이 복사되지 않을 수 있습니다.

​

원하는 셀이 아니라 표자체를 선택하면 모든 셀들이 복사됩니다.

​

도형과 중복되기 때문에 기존 표의 해당 셀의 데이터는 삭제됩니다.

만일을 위해 기존 표는 보이지 않는 도형으로 백업합니다.

 

실행화면 캡쳐영상입니다.

코드는 아래와 같습니다.

 Sub Cell2Shape()
    
    Dim sld As Slide, shp As Shape, cshp As Shape, nshp As Shape
    Dim tbl As Table
    Dim r As Integer, c As Integer, tcnt&
    Dim SelCell() As Boolean
    
    'On Error GoTo Oops
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    Set sld = shp.Parent
    Set tbl = shp.Table
    
    '선택된 셀들 기억
    ReDim SelCell(1 To tbl.Rows.Count, 1 To tbl.Columns.Count)
    For r = 1 To tbl.Rows.Count
        For c = 1 To tbl.Columns.Count
            If tbl.Cell(r, c).Selected Then
                SelCell(r, c) = True
            End If
        Next c
    Next r
    
    '기존 표도형을 백업
    tcnt = sld.Shapes.Count
    shp.Duplicate (1)
    While sld.Shapes.Count <= tcnt: DoEvents: Wend 'wait
    With sld.Shapes(sld.Shapes.Count)
        .Name = shp.Name & "_Backup"
        .Visible = msoFalse
        .Left = shp.Left
        .Top = shp.Top
    End With
     
    '각 셀내용을 순환하면서 도형으로 복제
    For r = 1 To tbl.Rows.Count
        For c = 1 To tbl.Columns.Count
            'If tbl.Cell(r, c).Shape.TextFrame2.HasText Then
             If SelCell(r, c) Then
                Set cshp = tbl.Cell(r, c).Shape
                cshp.TextFrame2.TextRange.Copy
                tcnt = sld.Shapes.Count
                Set nshp = sld.Shapes.Paste(1)
                While sld.Shapes.Count <= tcnt: DoEvents: Wend 'wait
                
                nshp.Name = "Cell_" & r & "_" & c
                nshp.Left = cshp.Left
                nshp.Top = cshp.Top
                nshp.Width = cshp.Width
                nshp.Height = cshp.Height
                
                With nshp.TextFrame2
                    .AutoSize = msoAutoSizeNone
                    .VerticalAnchor = cshp.TextFrame2.VerticalAnchor '세로정렬
                    '.TextRange.Font.Bold = cshp.TextFrame2.TextRange.Font.Bold '진하게 여부
                End With

                '기존 셀내용 삭제
                cshp.TextFrame2.DeleteText
                 
            End If
        Next c
    Next r
    
Oops:
    If Err Then MsgBox Err.Description
    
 End Sub

 

첨부파일을 항상 매크로 허용해서 여세요. 파일속성에서 차단해제후 적용을 추천합니다.

 

Cell2Shape1.pptm

0.05MB