[VBA] 다중 Collection으로 단어조합하기

어떻게 보면 로또번호 조합같은 문제이다.

 

나열된 단어속에서 일정 숫자까지만 추출해서 특정 단어를 조합하여

새로운 문구를 만드는 문제이다. 

여기에 사용한 구문은 다중 컬렉션을 통해 순차적으로 조합을 만들어가면서

최종적으로 중복없는 8개의 단어조합을 만드면 되겠다.

 

코드 진행은 이렇다.

1. 단어들을 순환하면서 Acol 컬렉션에 담는다.

2.  Acol 컬렉션에서 6개만 무작위로 뽑아서 Bcol에 추가한다.

3. Acol 에서 뽑은 6개의 단어에 [숙, 제]를 Bcol에 추가한다.

4. Bcol을 순환하며 랜덤으로 조합하여 Ccol에 추가해라

5. Ccol에 추가된 문구를 Vtemp 임시배열에 담은 후

6. Join 함수로 결합한다. 

7. 결합해서 똑같이 Dcol에 추가해보면 중복이면 Dcol에 추가가 되지 않겠고

8.  중복이 아니면 Vc = join(Vtemp, " ") 이 작동하므로 Vc가 작동한다는 것은

고유값이라는 뜻이므로 rngX에 Vc의 값들을 300개까지 출력한다.

Option Explicit

Sub test()
    
    Dim Acol As New Collection, Bcol As New Collection, Ccol As New Collection, Dcol As New Collection
    Dim Va: Va = [a4:a12]
    Dim V, Vtemp(1 To 8), Vc
    Dim i&, sKey&
    Dim rngX As Range: Set rngX = [d4]
    
    For Each V In Va
    
        Acol.Add V                                              ' 단어 전체를 Acol 컬렉션에 담아라
    
    Next V
   
    Do Until Dcol.Count >= 300                                  '= 조합문자 300 개를 출력
    On Error Resume Next
        
        Do Until Bcol.Count = 6                                 '= 1차 : 6개의 중복없는 고유문자가 될때까지 순환
            sKey = WorksheetFunction.RandBetween(1, Acol.Count) '= 랜덤하게 숫자를 가져와서 Skey에 담아라
            Bcol.Add Acol(sKey), CStr(sKey)                     '= Bcol에 추가해라
        Loop
            
            Bcol.Add "숙": Bcol.Add "제"                        '= Bcol에서 추출한 6개에 + [숙, 제]  를 추가해라
            
        Do Until Ccol.Count = 8                                 '= 숙제를 포함한 조합문자를 구성해라
            sKey = WorksheetFunction.RandBetween(1, Bcol.Count)
            Ccol.Add Bcol(sKey), CStr(sKey)                     '= 추출한 문자를 Ccol에 추가해라
        Loop

        For i = 1 To 8
            Vtemp(i) = Ccol(i)                                  '= 8개의 조합된 값들을 임시배열에 담아라
        Next i
            
            Vc = Join(Vtemp, " ")                               '= 임시배열을 띄어쓰기로 합쳐라
            Dcol.Add Vc, CStr(Vc)                               '= Dcol에 추가해라 / 만일 중복이라면 추가 되지 않을 것이다.
            
            rngX = Vc                                           '= Vc가 중복이 아니기에 고유값을 rngX에 출력해라
            Set rngX = rngX.Offset(1)                           '= 다음행으로 이동
    
    On Error GoTo 0
        Set Bcol = New Collection: Set Ccol = New Collection    '= 다음을 위해 컬렉션 초기화
    Loop
    
    MsgBox "출력완료"
End Sub

 

특정단어(완성).xlsm

0.03MB