[파워포인트 VBA] 차트 데이터레이블 일괄 변경 매크로

매크로 설명

• 파워포인트 차트의 데이터레이블 설정을 일괄적으로 변경하는 매크로이다.
• 특히 데이터레이블 위치를 임의로 변경하는 노가다를 해야하는 경우에 유용할 것 같다.
• 이 매크로는 엑셀을 통해 파워포인트의 차트를 제어하는 방식으로 작동한다.
• 파워포인트의 차트 개체모델에 접근하는 방식과 엑셀의 차트 개체모델에 접근하는 방식이 다르기 때문에,
• 엑셀에 적용하는 경우에는 오류가 발생 수도 있다.

매크로 실행 동영상

VBA Code

Option Explicit
Sub chart_batch()
Dim pptRef As PowerPoint.Application
Dim curSlide As Long
Dim shName As String
Dim objChart As PowerPoint.Chart
Dim seriesCnt, aaCnt As Long
Dim dtTopOrj As Long
Dim i As Long, j As Long
Dim chartTyp As Long
 
Set pptRef = GetObject(, "PowerPoint.Application") '현재 ppt initiate
pptRef.Activate 'ppt 활성화
curSlide = pptRef.ActiveWindow.Selection.SlideRange.SlideIndex '현재 슬라이드 Idx
shName = pptRef.ActiveWindow.Selection.ShapeRange.Name '현재 슬라이드에서 선택한 개체의 이름
'▲ 이 짓을 왜 하는가 -> 현재 선택한 개체를 동적으로 변수에 할당하기 위함
'즉, 슬라이드와 쉐이프를 직접 선택하는 이런 형식 'Slides(1)' 을 피하기 위함
 
On Error Resume Next
  Set objChart = pptRef.ActivePresentation.Slides(curSlide).Shapes(shName).Chart '선택한 차트를 objChart 변수 지정
  If Err.Number = -2147024809 Then '선택한 놈이 차트가 아니면
    MsgBox "차트를 선택하세요", vbOKOnly '오류 띄우고 종료
    Exit Sub
  End If
On Error GoTo 0
 
With objChart '차트 내에서
  seriesCnt = .FullSeriesCollection.Count '계열 수 카운트
  aaCnt = .FullSeriesCollection(seriesCnt).Points.Count '항목(가로축) 수 카운트
    For i = 1 To seriesCnt '각 차트 계열을 돌면서
      chartTyp = .FullSeriesCollection(i).Type '계열별 차트 형식
      Select Case chartTyp 'i계열의 차트 형식이
        Case 3 '세로 막대그래프인 경우
          .FullSeriesCollection(i).Select
          .SetElement msoElementDataLabelOutSideEnd '바깥쪽 끝 레이블
        Case 4 '선 그래프인 경우
          .FullSeriesCollection(i).Select
          .SetElement msoElementDataLabelTop '위쪽 레이블
      End Select
 
      For j = 1 To aaCnt '각 계열 내 항목을 돌면서
        objChart.Select
        dtTopOrj = .FullSeriesCollection(i).Points(j).DataLabel.Top '바깥쪽 끝의 데이터레이블 Top 위치 저장
        .FullSeriesCollection(i).Points(j).DataLabel.Top = dtTopOrj - 10 '데이터레이블 위치를 기존보다 위쪽으로 10만큼 이동
      Next j
    Next i
End With
 
Set objChart = Nothing
Set pptRef = Nothing
End Sub

 Copyright (2018) Ruahneuma. All Rights Reserved.