엑셀연동] 자동 방배정 및 명단 출력 2

관련: 지식인 2

 

 

이번에는 Alllocate1.xlsm 엑셀에서 아래 매크로로 자동으로 방호수를 입력하게 해보았습니다.

 

배정 규칙은 아래와 같습니다.

1. 시작 방번호는 101호부터 시작합니다.
   ( 가능한 방번호가 정해져있을 경우 배열로 방번호 목록을 미리 만들어 두어야 합니다.  )
2. 각 국가별 시트 순서대로 배정합니다.
3. 여자들부터 방을 배정합니다.
4. 성별이 다르면 새로운 방번호로 넘어갑니다.
5. 국가가 달라도 새로운 방번호로 넘어갑니다.
6. 6명을 넘으면 새로운 방번호로 넘어갑니다.

 

 

 

엑셀 자동으로 방배정하는 VBA코드:

Option Explicit

Sub Allocate1()
    
    Dim sht As Worksheet
    Dim lastR As Range
    Dim r As Range, room As Integer, cnt As Integer
    
    'starting room number
    room = 101
    
    'Set sht = ActiveSheet
    For Each sht In ThisWorkbook.Worksheets

        Set lastR = sht.Cells(sht.Rows.Count, "A").End(xlUp)
        If lastR.Row < 2 Then Exit Sub
        If cnt > 0 Then room = room + 1
        
        'Female first
        cnt = 0
        For Each r In sht.Range("A2:A" & lastR.Row)
            If r.Offset(, 3) = "F" Then
                cnt = cnt + 1
                r.Offset(, 4) = room
                If cnt >= 6 Then
                    room = room + 1: cnt = 0
                End If
            End If
        Next r
        If cnt > 0 Then room = room + 1
        
        'Male
         cnt = 0
        For Each r In sht.Range("A2:A" & lastR.Row)
            If r.Offset(, 3) = "M" Then
                cnt = cnt + 1
                r.Offset(, 4) = room
                If cnt >= 6 Then
                    room = room + 1: cnt = 0
                End If
            End If
        Next r
    
        'Outline
        sht.Range("E2:E" & lastR.Row).Borders.LineStyle = xlContinuous
        For Each r In sht.Range("E2:E" & lastR.Row)
            If r = r.Offset(1) Then
                r.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
            End If
        Next r
        
    Next sht
    
    Allocate1_Sort
    
End Sub

 

그리고 나서 (자동으로) 여자부터 방번호순으로 정렬시켜서 '원본 파일 _Sorted.xlsx' 파일에 저장합니다.

이 정렬된 파일을 가지고 파워포인트에서 명단을 출력하게 됩니다.

 

 

자동 정렬하는 VBA코드:

Sub Allocate1_Sort()
    
    Dim sht As Worksheet, book As Workbook
    Dim r As Range, lastR As Range
    Dim tmp As String
    
    tmp = ThisWorkbook.FullName
    tmp = Left(tmp, InStrRev(tmp, ".") - 1) & "_Sorted.xlsx"
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs Filename:=tmp, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.DisplayAlerts = True
    
    'Set sht = ActiveSheet
    Set book = Workbooks.Open(tmp)
    For Each sht In book.Worksheets
    
        Set lastR = sht.Cells(sht.Rows.Count, "A").End(xlUp)
        
        With sht.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("E:E")
            .Header = xlYes
            .SetRange Rng:=Range("A:E")
            .Apply
        End With
        
        'Outline
        sht.Range("E2:E" & lastR.Row).Borders.LineStyle = xlContinuous
        For Each r In sht.Range("E2:E" & lastR.Row)
            If r = r.Offset(1) Then
                r.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
            End If
        Next r
    Next sht
    book.Save
     
End Sub

 

 

 

이제  파워포인트에서의 작업입니다.

 

Allocate2.pptm 파일을 열고 Alt-F8 누르고 Allocate2 를 실행합니다.

 

 

'원본 파일 _Sorted.xlsx' 을 불러오면 방번호순으로 번호와 이름을 각 슬라이드에 출력합니다.

시트순서 즉 국가순서로 계속 마지막 시트까지, 마지막 방번호까지 슬라이드와 표를 생성합니다.

(인쇄 옵션은 숨겨진 슬라이드는 제외하도록 설정합니다.)

 

 

출력하는 VBA 코드:

Sub Allocate2()

    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
    '각 국가별 시트 순환
    For Each sht In book.worksheets
    
       'A열 맨 아래행 구하기
       LastRow = sht.Cells(sht.Rows.Count, "A").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("A2:A" & LastRow)
            
           '방이름/방번호
           room = rng.Offset(, 4)
           
           '방이 다르면/바뀌면 슬라이드 추가
           If room <> rng.Offset(-1, 4) Then
               '마지막 슬라이드를 복제
               Set sld = pres.Slides(pres.Slides.Count).Duplicate(1)
               '마지막 바로 앞으로 보내기
               sld.MoveTo pres.Slides.Count - 1
               '슬라이드 감추기는 취소
               sld.SlideShowTransition.Hidden = False
               '국가명
               sld.Shapes("Nationality").TextFrame.TextRange = rng.Offset(, 2)
               '방호수
               sld.Shapes("Group").Table.Cell(1, 1).Shape.TextFrame.TextRange = rng.Offset(, 4)
               '표의 행위치는 초기화
               r = 0
           End If
           
           r = r + 1
           '각 컬럼 별로 입력
           sld.Shapes("Group").Table.Cell(r + 1, 1).Shape.TextFrame.TextRange = rng
           sld.Shapes("Group").Table.Cell(r + 1, 2).Shape.TextFrame.TextRange = rng.Offset(, 1)
    
       Next rng
    
    Next sht
    
    '기본 슬라이드는 슬라이드쇼에서 감춤
    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

 

결과물:

​

위 작업은 설계, 코딩/디버깅과 테스트에  시간과 노력이 소요되는  지식인 Expert수준의 작업이었습니다.

 

 

방배정 명단과 자동 방배정

Allocate1.xlsm

0.05MB

 

방배정 후 자동 정렬 결과

Allocate1_Sorted.xlsx

0.04MB

 

방배정 정렬결과 파일로 명단 출력

Allocate2.pptm

0.05MB

 

 

엑셀과 파워포인트 연동 작업 예시였습니다.