엑셀연동] 방배정 명단 출력 1

 

관련: 지식인 1 

 

 엑셀양식에 아래처럼 방을 구분하여 배정하고

​

 아래처럼 방별로 배정명단을 출력하는 작업입니다.

​

코드 내용:

Option Explicit
 
Sub GeneratePPT()

    On Error GoTo Done:
    
    Dim pres As Presentation
    Set pres = ActivePresentation
    Dim sld As Slide
    Dim shp As Shape
    
    Dim XLapp As Object 'Excel.Application
    Set XLapp = CreateObject("Excel.Application")
    Dim book As Object  'Excel.Workbook
    Dim sht As Object   'Excel.Worksheet
    Dim rng As Object   'Excel.Range
    Dim LastRow As Long, LastCol As Long, c As Long
    Dim TargetXLS As String, TargetPPT As String
    Dim room As String
    Dim r As Integer
    
    '엑셀 파일 선택 상자
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "엑셀목록", "*.xls?"
        If .Show = -1 Then TargetXLS = .SelectedItems(1)
    End With
    If Len(TargetXLS) = 0 Then GoTo Done:
    Set book = XLapp.Workbooks.Open(FileName:=TargetXLS, ReadOnly:=True)
    Set sht = book.ActiveSheet
    
    'A열 맨 아래행 구하기
    LastRow = sht.Cells(sht.Rows.Count, 1).End(-4162).Row       'xlUp(-4162)
    If LastRow <= 1 Then MsgBox "목록이 1개 이하입니다.": GoTo Done
    
    '1행 맨 오른쪽 셀 구하기
    LastCol = sht.Cells(1, sht.Columns.Count).End(-4159).Column 'xlToLeft(-4159)
    
    '모든 행에 대해 순환, 번호열 기준
    For Each rng In sht.Range("B2:B" & LastRow)
         
        '방이름/방번호
        room = rng.Offset(, 2)
        
        '방이 다르면/바뀌면 슬라이드 추가
        If room <> rng.Offset(-1, 2) Then
            '마지막 슬라이드를 복제
            Set sld = pres.Slides(pres.Slides.Count).Duplicate(1)
            '마지막 바로 앞으로 보내기
            sld.MoveTo pres.Slides.Count - 1
            '슬라이드 감추기는 취소
            sld.SlideShowTransition.Hidden = False
            '반명
            sld.Shapes("반").TextFrame.TextRange = rng.Offset(, -1) & "반"
            '방호수
            sld.Shapes("표").Table.Cell(1, 1).Shape.TextFrame.TextRange = rng.Offset(, 2) & " 호"
            '표의 행위치는 초기화
            r = 0
        End If
        
        r = r + 1
        '각 컬럼 별로 입력
        sld.Shapes("표").Table.Cell(r + 1, 1).Shape.TextFrame.TextRange = rng
        sld.Shapes("표").Table.Cell(r + 1, 2).Shape.TextFrame.TextRange = rng.Offset(, 1)
 
    Next rng
    
    '기본 슬라이드는 슬라이드쇼에서 감춤
    pres.Slides(pres.Slides.Count).SlideShowTransition.Hidden = msoTrue
    '숨겨진 슬라이드 인쇄 안함
    pres.PrintOptions.PrintHiddenSlides = msoFalse
    
    '파일명 변경 저장
    'TargetPPT = pres.FullName
    'TargetPPT = Left(TargetPPT, InStrRev(TargetPPT, ".") - 1) & _
        "_자동생성" & (LastRow - 1) & ".pptx"
    'PPTfile.SaveAs FileName:=TargetPPT
Done:
    If Err Then MsgBox Err.Description
    If Not XLapp Is Nothing Then XLapp.Quit:    Set XLapp = Nothing
     
End Sub

 매크로 실행 결과

​

 

명단 양식:

엑셀2PPT_명단.xlsx

0.01MB

 출력 양식:

엑셀2PPT_방배정.pptm

0.06MB

 

 

​

​참고) 아래와 같은 기존 다른 예시도 참고하세요.

VBA를 이용해서 엑셀명단을 PPT슬라이드에 채워 넣는 비슷한 사례를 모았습니다.

 

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102&docId=323539444

엑셀 데이터 통해 파워포인트 만드는 매크로

 

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=437449137

엑셀 매크로 기능 이용해서 파워포인트 슬라이드 자동생성 방법(4행의 엑...

 

 

https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102&docId=362383614

 

PPT(파워포인트)로 메일머지 하는 방법을 알려주세요! (VBA)

 

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102&docId=326720555

안녕하세요, 엑셀 -> 파워포인트 매크로 질문드립니다.

 

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=459877084

파워포인트 질문

 

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=459985130

ppt 엑셀 매크로 질문