| |
'------------------------------
Sub dic_arrayList()
'------------------------------
Dim ADic As New Scripting.Dictionary
Dim BDic As Scripting.Dictionary
Dim oList As Object
Dim varX As Variant: varX = [A1].CurrentRegion.Value
Dim vKey As Variant
Dim vDate As Variant
Application.ScreenUpdating = False
'----------------------------------
For r = 2 To UBound(varX, 1)
'----------------------------------
' 장소
vKey = varX(r, 3)
' 장소가 딕셔녀리에 있으면
'------------------------------
If ADic.Exists(vKey) Then
'------------------------------
Set BDic = ADic.Item(vKey)
vDate = varX(r, 1)
'------------------------------
If BDic.Exists(vDate) Then
'------------------------------
' ArrayList에 엾으면 추가
If Not BDic.Item(vDate).contains(varX(r, 2)) Then BDic.Item(vDate).Add varX(r, 2)
Else
' ArrayList 생성
Set oList = CreateObject("System.Collections.ArrayList")
' ArrayyList에 이름 추가
oList.Add varX(r, 2)
' dictionary에 arrayList추가
BDic.Add vDate, oList
'------------------------------
End If
'------------------------------
Else ' not exist
Set oList = CreateObject("System.Collections.ArrayList")
' 이름 넣기
oList.Add varX(r, 2)
Set BDic = New Scripting.Dictionary
BDic.Add varX(r, 1), oList
ADic.Add vKey, BDic
End If
Next r
' delete existing sheets
Call delete_shts
Dim shtX As Worksheet
Dim j As Long
'Stop
'-------------------------------------
For Each skey In ADic.Keys
'-------------------------------------
'시트 생성
Set shtX = Worksheets.Add(After:=Worksheets(Worksheets.Count))
shtX.Name = skey
' 제목 행 입력
shtX.[A1:C1].Value = Array("날짜", "이름", "장소")
Set BDic = ADic.Item(skey)
j = 2
'---------------------------------------------------
For Each Key In BDic.Keys
'---------------------------------------------------
shtX.Cells(j, 1).Value = Key
shtX.Cells(j, 2).Value = Join(BDic.Item(Key).toarray, ",")
shtX.Cells(j, 3).Value = skey
j = j + 1
Next Key
Next
Worksheets("main").Activate
Application.ScreenUpdating = True
MsgBox "Job Done"
End Sub
'---------------------------------
Sub delete_shts()
'---------------------------------
Dim sht As Worksheet
Application.DisplayAlerts = False
For Each sht In Worksheets
If sht.Name <> "main" Then sht.Delete
Next sht
Application.DisplayAlerts = True
End Sub
|
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
