Option Explicit
' 아래 루틴들은 Microsoft PowerPoint xx.x Object Library.를 필요로 함
' xx.x 는 office version에 따라 참조되는 기준 (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
' 아래 루틴에서 참조되는 전역 변수 선언
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Dim cntCht As Integer
Private Sub ToPPTSlide()
' 워크 시트에 존재하는 모든 chart를 새 파워포인트 슬라이드로 옮김
Dim sht As Worksheet
Dim objCht As Object
Dim j As Integer, Unit As Integer, i As Integer
Dim row As Integer, col As Integer
Dim chtTitle As String
' 속도를 위해 화면 갱신 중지
Application.ScreenUpdating = False
' 워크북에 존재하는 chart의 갯수를 셈.
For Each sht In ActiveWorkbook.Worksheets
cntCht = cntCht + sht.ChartObjects.Count
Next sht
' chart가 없을 경우 에러 메시지
If cntCht + ActiveWorkbook.Charts.Count < 1 Then
MsgBox " 내보내기 할 차트가 없습니다!", vbCritical, "경 고"
Exit Sub
End If
' 열려있는 파워포인트가 있는지 체크
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
' 파워포인트 실행하고 프리젠테이션 생성
If pptApp Is Nothing Then Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
' 슬라이드 수를 세고 뒤에 하나 더 추가
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
' 워크시트에 존재하는 모든 차트를 내보냄
For Each sht In ActiveWorkbook.Worksheets
For Each objCht In sht.ChartObjects
Call ToPPT(objCht.Chart)
Next objCht
Next sht
' chart 시트에 별도로 만들어진 chart를 내보냄
For Each objCht In ActiveWorkbook.Charts
Call ToPPT(objCht)
Next objCht
' 위의 경우 제목과 붙여진 차트의 형식 갖추기
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
' 그림이 붙여질 위치
If .Type = msoPicture Then
' 비례 유지를 취소
.LockAspectRatio = 0
.Top = 86
.Left = 34
.Height = 410
.Width = 650
End If
' 제목 박스의 내용과 글꼴 변경
If .Type = msoTextBox Then
With .TextFrame.TextRange
.Font.Color = vbBlue
.Font.Name = "맑은 고딕"
.Font.Size = 28
.Font.Bold = msoTrue
.ParagraphFormat.Alignment = ppAlignCenter
.Text = chtTitle
End With
End If
End With
Next j
End Sub
Private Sub ToPPT(xlCht As Chart)
On Error Resume Next
xlCht.ChartArea.Copy
' 필요에 따라 ppPasetJPG를 여러 포멧으로 변경하여 내보냄
pptSlide.Shapes.PasteSpecial ppPasteJPG
End Sub
Sub ChartsToPPT_By_9()
' 워크 시트에 존재하는 모든 chart를 새 파워포인트 슬라이드로 옮김
Dim sht As Worksheet
Dim objCht As Object
Dim j As Integer, Unit As Integer, i As Integer
Dim row As Integer, col As Integer
' 1열로 배치할 chart의 수
Unit = 3
' 속도를 위해 화면 갱신 중지
Application.ScreenUpdating = False
' 워크북에 존재하는 chart의 갯수를 셈.
For Each sht In ActiveWorkbook.Worksheets
cntCht = cntCht + sht.ChartObjects.Count
Next sht
' chart가 없을 경우 에러 메시지
If cntCht + ActiveWorkbook.Charts.Count < 1 Then
MsgBox " 내보내기 할 차트가 없습니다!", vbCritical, "경 고"
Exit Sub
End If
' 열려있는 파워포인트가 있는지 체크
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
' 파워포인트 실행하고 프리젠테이션 생성
If pptApp Is Nothing Then Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
' 슬라이드 수를 세고 뒤에 하나 더 추가
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
' 워크시트에 존재하는 모든 차트를 내보냄
For Each sht In ActiveWorkbook.Worksheets
For Each objCht In sht.ChartObjects
Call ToPPT(objCht.Chart)
Next objCht
Next sht
' chart 시트에 별도로 만들어진 chart를 내보냄
For Each objCht In ActiveWorkbook.Charts
Call ToPPT(objCht)
Next objCht
' 위의 경우 제목과 붙여진 차트의 형식 갖추기
For j = 1 To pptSlide.Shapes.Count
If j > 9 Then
pptSlide.MoveTo j \ 9
End If
With pptSlide.Shapes(j)
' 그림이 정렬될 위치 결정
If .Type = msoPicture Then
Select Case ((j - 1) \ Unit)
Case 0
row = 150
col = (j Mod Unit) * 220
Case 1
row = 300
col = (j Mod Unit) * 220
Case 2
row = 450
col = (j Mod Unit) * 220
End Select
End If
' 원본과 비례 유지 False
.LockAspectRatio = 0
' 그림 정렬될 위치
.Top = row - 100
.Left = col + 40
.Height = 140
.Width = 200
End With
Next j
' 속도를 위해 중지되었던 갱신 진행
Application.ScreenUpdating = True
' 파워포인트 보이기
pptApp.Visible = True
' chart개수 초기화
cntCht = 0
' objects 지우기
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
'엑셀 시트에 ActiveX 버튼하나 만드시고 아래 코드 연결시킵니다.
'1은 슬라이드 한장에 시트하나, 9는 9장의 시트를 정렬시킵니다.
Private Sub CommandButton1_Click()
Dim kind As Integer
kind = Application.InputBox("차트보내기 1: 1장씩, 9: 9장씩")
If kind = 1 Then
Call ChartsToPPT_By_1
ElseIf kind = 9 Then
Call ChartsToPPT_By_9
End If
End Sub
6월 7 2016
엑셀(EXCEL) – 엑셀 시트의 모든 차트를 PPT 슬라이드에 하나씩 혹은 여러장씩 붙여넣기
이 팁의 시작은 아래의 질문을 해결하는 방법을 구걸로 아이디어를 찾는 것이었는데
http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3738549
엑셀 그래프를 자동으로 파워포인트로 옮겨주는 VBA나 매크로
비슷한 시기에 비슷한 내요의 질문이 올라와서 이것을 해결하는데 시간이 많이 걸렸네요.
아직도 9개 이상의 차트를 옮기면 슬라이드 하나에 붙여넣기를 해서 해결을 못했습니다.
며칠을 고민해도 차트 오브젝트를 추가 슬라이드에 복사하는 아이디어가 안 떠오르네요.
http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3741003
그래프 a4용지 사이즈에 이쁘게 넣는 방법 없을까요?
그냥 슬라이드 하나에 차트 옮기는 것은 쉬운데 하나에 여러 차트를 보기좋게 정렬까지는
할 수 있는데 차트의 갯수가 한 슬라이드의 기본 차트보다 많아지면 문제가 생기네요.
능력자들을 믿습니다. 해결 방법을 댓글로 주세요. 여기까지도 요령껏 사용하면 괜찮아요.
첨부 화일 : 20160607-Chart-To-PPT_By_9Cht
꼭 해결 방법 올려주세요. 능력자님!!!
By vinipapa • 무른모 • 0