엑셀 다중 드롭다운, 1시간 동안 끙끙대지 말고 3초 만에 만드세요.
안녕하세요. 데이터위자드입니다.유튜브에서 사용한 소스코드 전달드립니다.
기존사용하던 엑셀파일이 .xlsx이신분들은 해당 코드 사용시 저장을 xlsm으로 해주시면 됩니다.
' 1번코드 [일반모듈용]
Option Explicit
' 열 문자 추출 ("G3:G100" -> "G")
Function GetColLetter(rngText As String) As String
Dim i As Long
For i = 1 To Len(rngText)
If IsNumeric(Mid(rngText, i, 1)) Then
GetColLetter = Left(rngText, i - 1)
Exit Function
End If
Next i
End Function
' 카테고리 블록 시작열 찾기 (B,F,J,...)
Function FindCategoryColumn(ws As Worksheet, categoryName As String) As Long
Dim col As Long
Dim maxCol As Long
maxCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column
For col = 2 To maxCol Step 4
If Trim(ws.Cells(9, col).Value) = Trim(categoryName) Then
FindCategoryColumn = col
Exit Function
End If
Next col
FindCategoryColumn = 0
End Function
' 시트 설정 한 덩어리 읽어오기
Function GetCategoryConfig(wsC As Worksheet, sheetName As String, _
ByRef catName As String, _
ByRef rLarge As String, _
ByRef rMid As String, _
ByRef rSmall As String, _
ByRef startCol As Long) As Boolean
Dim c As Long
catName = ""
rLarge = ""
rMid = ""
rSmall = ""
startCol = 0
For c = 3 To 50
If Trim(wsC.Cells(2, c).Value) = sheetName Then
catName = Trim(wsC.Cells(3, c).Value)
rLarge = Trim(wsC.Cells(4, c).Value)
rMid = Trim(wsC.Cells(5, c).Value)
rSmall = Trim(wsC.Cells(6, c).Value) ' 비어있으면 ""가 들어감
Exit For
End If
Next c
If catName = "" Or rLarge = "" Then
GetCategoryConfig = False
Exit Function
End If
startCol = FindCategoryColumn(wsC, catName)
If startCol = 0 Then
GetCategoryConfig = False
Exit Function
End If
GetCategoryConfig = True
End Function
' 대분류, 중분류, 소분류 열 중 가장 데이터가 많은 마지막 행 찾기
Function GetMaxLastRow(ws As Worksheet, startCol As Long) As Long
Dim rL As Long, rM As Long, rS As Long
' 대분류 열 마지막 행
rL = ws.Cells(ws.Rows.Count, startCol).End(xlUp).Row
' 중분류 열 마지막 행
rM = ws.Cells(ws.Rows.Count, startCol + 1).End(xlUp).Row
' 소분류 열 마지막 행
rS = ws.Cells(ws.Rows.Count, startCol + 2).End(xlUp).Row
' 셋 중 가장 큰 값 찾기
GetMaxLastRow = rL
If rM > GetMaxLastRow Then GetMaxLastRow = rM
If rS > GetMaxLastRow Then GetMaxLastRow = rS
' 최소한 12행보다는 커야 함
If GetMaxLastRow < 12 Then GetMaxLastRow = 12
End Function
' 카테고리 시트에서 대분류 목록 만들기
Function BuildLargeList(wsC As Worksheet, startCol As Long) As String
Dim dict As Object
Dim lastRow As Long
Dim i As Long
Dim v As String
Set dict = CreateObject("Scripting.Dictionary")
lastRow = GetMaxLastRow(wsC, startCol)
For i = 12 To lastRow
v = Trim(wsC.Cells(i, startCol).Value)
If v <> "" And v <> "대분류" Then
If Not dict.Exists(v) Then dict.Add v, True
End If
Next i
If dict.Count = 0 Then
BuildLargeList = ""
Else
BuildLargeList = Join(dict.Keys, ",")
End If
End Function
' 선택된 대분류에 대한 중분류 목록 만들기
Function BuildMidList(wsC As Worksheet, startCol As Long, largeVal As String) As String
Dim dict As Object
Dim lastRow As Long
Dim i As Long
Dim curLarge As String
Dim midVal As String
Dim inLarge As Boolean
Set dict = CreateObject("Scripting.Dictionary")
lastRow = GetMaxLastRow(wsC, startCol)
inLarge = False
curLarge = ""
For i = 12 To lastRow
If Trim(wsC.Cells(i, startCol).Value) <> "" And _
Trim(wsC.Cells(i, startCol).Value) <> "대분류" Then
curLarge = Trim(wsC.Cells(i, startCol).Value)
If curLarge = largeVal Then
inLarge = True
ElseIf inLarge And curLarge <> largeVal Then
Exit For
End If
End If
If inLarge And curLarge = largeVal Then
midVal = Trim(wsC.Cells(i, startCol + 1).Value)
If midVal <> "" And midVal <> "중분류" Then
If Not dict.Exists(midVal) Then dict.Add midVal, True
End If
End If
Next i
If dict.Count = 0 Then
BuildMidList = ""
Else
BuildMidList = Join(dict.Keys, ",")
End If
End Function
' 선택된 대분류+중분류에 대한 소분류 목록 만들기
Function BuildSmallList(wsC As Worksheet, startCol As Long, largeVal As String, midVal As String) As String
Dim dict As Object
Dim lastRow As Long
Dim i As Long
Dim curLarge As String
Dim curMid As String
Dim smallVal As String
Dim inLarge As Boolean
Dim inMid As Boolean
Set dict = CreateObject("Scripting.Dictionary")
lastRow = GetMaxLastRow(wsC, startCol)
inLarge = False
inMid = False
curLarge = ""
curMid = ""
For i = 12 To lastRow
' 대분류 체크
If Trim(wsC.Cells(i, startCol).Value) <> "" And _
Trim(wsC.Cells(i, startCol).Value) <> "대분류" Then
curLarge = Trim(wsC.Cells(i, startCol).Value)
If curLarge = largeVal Then
inLarge = True
inMid = False
ElseIf inLarge And curLarge <> largeVal Then
Exit For
End If
End If
' 중분류 체크
If inLarge Then
If Trim(wsC.Cells(i, startCol + 1).Value) <> "" And _
Trim(wsC.Cells(i, startCol + 1).Value) <> "중분류" Then
curMid = Trim(wsC.Cells(i, startCol + 1).Value)
If curMid = midVal Then
inMid = True
ElseIf inMid And curMid <> midVal Then
inMid = False
End If
End If
End If
' 소분류 수집
If inLarge And inMid Then
smallVal = Trim(wsC.Cells(i, startCol + 2).Value)
If smallVal <> "" And smallVal <> "소분류" Then
If Not dict.Exists(smallVal) Then dict.Add smallVal, True
End If
End If
Next i
If dict.Count = 0 Then
BuildSmallList = ""
Else
BuildSmallList = Join(dict.Keys, ",")
End If
End Function
' 초기 세팅: 각 시트에 대분류 드롭다운만 걸기
Sub 다중목록상자만들기()
Dim wsC As Worksheet
Dim wsT As Worksheet
Dim catName As String
Dim rLarge As String, rMid As String, rSmall As String
Dim startCol As Long
Dim col As Long
Dim shName As String
Dim listLarge As String
On Error Resume Next
Set wsC = ThisWorkbook.Sheets("카테고리")
On Error GoTo 0
If wsC Is Nothing Then
MsgBox "카테고리 시트 먼저 만들어주세요. 유튜브 : 엑셀퀘스트 참고"
Exit Sub
End If
For col = 3 To 50 ' C열부터 오른쪽으로
shName = Trim(wsC.Cells(2, col).Value)
If shName = "" Then GoTo NextCol
On Error Resume Next
Set wsT = ThisWorkbook.Sheets(shName)
On Error GoTo 0
If wsT Is Nothing Then GoTo NextCol
If Not GetCategoryConfig(wsC, shName, catName, rLarge, rMid, rSmall, startCol) Then GoTo NextCol
' === [수정됨] 소분류가 빈칸(2단 구조)일 때 에러 방지 ===
On Error Resume Next
wsT.Range(rLarge).Validation.Delete
wsT.Range(rMid).Validation.Delete
If rSmall <> "" Then wsT.Range(rSmall).Validation.Delete ' <--- 여기가 핵심 수정!
On Error GoTo 0
listLarge = BuildLargeList(wsC, startCol)
If listLarge <> "" Then
With wsT.Range(rLarge).Validation
.Add Type:=xlValidateList, Formula1:=listLarge
End With
End If
NextCol:
Set wsT = Nothing
Next col
MsgBox "대분류 목록까지 설정 완료"
End Sub
Sub 카테고리시트_자동생성()
Dim ws As Worksheet
Dim i As Long
Dim startCol As Long
Dim rngTable As Range, rngHeader As Range, rngData As Range
Dim btn As Shape ' 버튼 개체 변수 추가
' 1. 기존 시트 확인 및 삭제
On Error Resume Next
Set ws = ThisWorkbook.Sheets("카테고리")
On Error GoTo 0
If Not ws Is Nothing Then
If MsgBox("'카테고리' 시트가 이미 존재합니다. 삭제하고 새로 만들까요?" & vbCr & _
"(기존 데이터는 모두 사라집니다)", vbYesNo + vbExclamation, "엑셀퀘스트") = vbNo Then
Exit Sub
End If
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
' 2. 새 시트 생성
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "카테고리"
ActiveWindow.DisplayGridlines = False
' 3. 전체 배경 흰색 & 열 너비 통일
ws.Cells.Interior.Color = xlNone
ws.Range("B:AZ").ColumnWidth = 12
' ====================================================
' Part 1. 상단 설정 테이블 (B2:O6)
' ====================================================
ws.Range("B2").Value = "반영시트"
ws.Range("B3").Value = "카테고리 종류"
ws.Range("B4").Value = "대분류 열"
ws.Range("B5").Value = "중분류 열"
ws.Range("B6").Value = "소분류 열"
With ws.Range("B2:O6")
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With ws.Range("B2:B6")
.Interior.Color = RGB(217, 217, 217)
.Font.Bold = True
End With
' ====================================================
' Part 2. 카테고리 블록 10개 생성
' ====================================================
For i = 0 To 9
startCol = 2 + (i * 4)
' (1) 카테고리 이름 (9행)
Set rngHeader = ws.Cells(9, startCol)
With rngHeader
.Value = "카테고리" & (i + 1)
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
' (2) 대/중/소 헤더 (11행)
ws.Cells(11, startCol).Value = "대분류"
ws.Cells(11, startCol + 1).Value = "중분류"
ws.Cells(11, startCol + 2).Value = "소분류"
Set rngTable = ws.Range(ws.Cells(11, startCol), ws.Cells(11, startCol + 2))
With rngTable
.Interior.Color = RGB(146, 208, 80)
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
' (3) 데이터 입력 칸
Set rngData = ws.Range(ws.Cells(12, startCol), ws.Cells(72, startCol + 2))
With rngData
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
Next i
' ====================================================
' Part 4. Q2 셀에 실행 버튼 만들기 (NEW!)
' ====================================================
' 둥근 모서리 사각형 생성 (위치: Q2)
Set btn = ws.Shapes.AddShape(msoShapeRoundedRectangle, _
ws.Range("Q2").Left, _
ws.Range("Q2").Top, _
120, 35) ' 너비 120, 높이 35
With btn
' 1) 텍스트 설정
.TextFrame.Characters.Text = "목록상자 적용"
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.Characters.Font.Bold = True
.TextFrame.Characters.Font.Size = 11
.TextFrame.Characters.Font.Color = vbWhite
' 2) 색상 설정 (진한 회색/검정 계열로 깔끔하게)
.Fill.ForeColor.RGB = RGB(64, 64, 64)
.Line.Visible = msoFalse
' 3) ★ 매크로 연결 ★
.OnAction = "다중목록상자만들기"
End With
' ====================================================
' Part 3. 마무리
' ====================================================
ws.Range("A1").Select
MsgBox "카테고리 시트와 '실행 버튼'이 생성되었습니다!" & vbCr & _
"데이터 입력 후 Q2의 [목록상자 적용] 버튼만 누르세요.", vbInformation, "엑셀퀘스트"
End Sub
' 2번코드[현재통합문서용]
Option Explicit
' ★ 중앙 통제실: 모든 시트의 변경 사항을 여기서 감지합니다 ★
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsC As Worksheet
Dim catName As String
Dim rLarge As String, rMid As String, rSmall As String
Dim startCol As Long
Dim vLarge As String, vMid As String
Dim listMid As String, listSmall As String
Dim midCol As String, smallCol As String
Dim r As Long
' 복수 셀 선택 시 중단
If Target.CountLarge > 1 Then Exit Sub
' 에러 발생 시 무조건 CleanExit로 보내서 이벤트를 다시 켜도록 설정
On Error GoTo CleanExit
' 카테고리 시트 확인
On Error Resume Next
Set wsC = ThisWorkbook.Sheets("카테고리")
On Error GoTo CleanExit
If wsC Is Nothing Then Exit Sub
' 설정값 불러오기
If Not GetCategoryConfig(wsC, Sh.Name, catName, rLarge, rMid, rSmall, startCol) Then Exit Sub
' === 여기서부터 이벤트 끄기 ===
Application.EnableEvents = False
r = Target.Row
midCol = GetColLetter(rMid)
' [수정] 소분류가 비어있을 경우(2단 구조)를 대비해 smallCol 처리
If rSmall <> "" Then
smallCol = GetColLetter(rSmall)
Else
smallCol = ""
End If
' ---------------------------------------------------------
' 1. 대분류 셀 변경 시
' ---------------------------------------------------------
If Not Intersect(Target, Sh.Range(rLarge)) Is Nothing Then
' (1) 중분류 초기화
Sh.Range(midCol & r).ClearContents
Sh.Range(midCol & r).Validation.Delete
' (2) 소분류 초기화 (소분류 설정이 있을 때만!)
If smallCol <> "" Then
Sh.Range(smallCol & r).ClearContents
Sh.Range(smallCol & r).Validation.Delete
End If
vLarge = Trim(Target.Value)
' 대분류 값이 있을 때만 중분류 목록 생성
If vLarge <> "" Then
listMid = BuildMidList(wsC, startCol, vLarge)
If listMid <> "" Then
With Sh.Range(midCol & r).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=listMid
End With
End If
End If
End If
' ---------------------------------------------------------
' 2. 중분류 셀 변경 시 (소분류 설정이 있을 때만 작동)
' ---------------------------------------------------------
If smallCol <> "" Then
If Not Intersect(Target, Sh.Range(rMid)) Is Nothing Then
' 소분류 초기화
Sh.Range(smallCol & r).ClearContents
Sh.Range(smallCol & r).Validation.Delete
' 대분류값 읽기
vLarge = Trim(Sh.Range(GetColLetter(rLarge) & r).Value)
vMid = Trim(Target.Value)
' 대분류와 중분류가 모두 있을 때만 소분류 목록 생성
If vLarge <> "" And vMid <> "" Then
listSmall = BuildSmallList(wsC, startCol, vLarge, vMid)
If listSmall <> "" Then
With Sh.Range(smallCol & r).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=listSmall
End With
End If
End If
End If
End If
CleanExit:
' 에러가 나든 정상 종료되든 무조건 실행됨
Application.EnableEvents = True
If Err.Number <> 0 Then
' 디버깅용: 배포시에는 주석 처리해도 됨
' MsgBox "오류 발생: " & Err.Description
End If
End Sub