팀별, 팀원을 섞어서 출석부 만들기

http://cafe.naver.com/excelmaster/131389 에 올라온 질문

7개 팀이 있고 한개 팀에 최대 5명의 팀원이 있다.

1. 7개 팀을 섞고

2. 팀원을 섞어서

서로 겹치지 않게 순서표를 짜는 매크로

Option Base 1
Option Explicit
 
Sub Macro()
 
    Dim wsTable As Worksheet: Set wsTable = Sheets("표")
    Dim wsList As Worksheet: Set wsList = Sheets("순서")
    Dim v$()
    Dim vRnd, vTable
    Dim rnG As Range, rnGList As Range
    Dim i%, j%, a%, b%
    Dim intMax%, intMax2%, cntMan%, tmP
    
    '기존자료 초기화
    Set rnGList = wsList.Range("G6:L19").SpecialCells(2, 1).Offset(, 1)
    rnGList.ClearContents
    
    '직원들 배열에 삽입
    With wsTable.Range("A1").CurrentRegion
        Set rnG = .Offset(, 1).Resize(, .Columns.Count - 1)
    End With
    
    '변수설정
    vTable = rnG    '전체 직원 배열에 삽입
    cntMan = rnG.SpecialCells(2).Count  '총 직원 숫자
    intMax = UBound(vTable, 1)  '팀 개수
    intMax2 = UBound(vTable, 2) '팀원 숫자
    b = 1
    ReDim vRnd(1, intMax)
    ReDim v(cntMan)
    
    '팀 번호를 배열에 삽입(팀별로 섞기 위한 준비)
    For i = 1 To intMax
        vRnd(1, i) = i
    Next i
    
    '팀별, 팀원 직원 순서 섞기
    vRnd = Shuffle(1, intMax, vRnd) '팀 순서 섞기
    vTable = Shuffle(intMax, intMax2, vTable)   '팀원 순서 섞기
    
    '팀을 섞어서 각 팀원을 배열에 넣기
    For j = 1 To intMax2
        For i = 1 To intMax
            If vTable(vRnd(1, i), j) <> "" Then
                v(b) = vTable(vRnd(1, i), j)
                b = b + 1
            End If
        Next i
    Next j
    
    '1일 간병순서에 리스트 출력하기
    i = 1
    For Each rnG In rnGList
        rnG.Value = v(i)
        i = i + 1
        If i > UBound(v) Then Exit For
    Next rnG
    
End Sub
 
Function Shuffle(Maxi%, Maxj%, v, Optional Min% = 1)
'팀 순서 섞는 사용자정의 함수
 
    Dim tmP, a%
    Dim i%, j%
    Dim vTmp
    
    For i = 1 To Maxi
        For j = 1 To Maxj
            a = Int(Maxj * Rnd() + Min)
            tmP = v(i, j)
            v(i, j) = v(i, a)
            v(i, a) = tmP
        Next j
    Next i
            
    Shuffle = v
 
End Function
 
Sub ClearData()
 
    Dim rnGList As Range
    Dim wsList As Worksheet
    
    '기존자료 초기화
    Set wsList = Sheets("순서")
    Set rnGList = wsList.Range("G6:L19").SpecialCells(2, 1).Offset(, 1)
    rnGList.ClearContents
    
End Sub
 

순서dd.xlsm