엑셀 - 각 시트의 중복 없는 이름 추출 하기 (VBA, 매크로)

• 동명이인이 있을 수 있지만, 우선 없다는 가정하에 진행해 봅니다.
• 버전/성능 이슈(수만 명, 구버전 등) → VBA 매크로가 가장 안정적입니다(딕셔너리로 중복 제거 + “시트명은 C컬럼에 1번만”).

 

---

엑셀 - 매크로(VBA) 적용 전

2) (가장 안정) VBA 매크로 방식 (구버전/대용량 추천)

장점: 수만 행에서도 빠르고 안정적(계산부하 최소). “FC/소득신고” 헤더를 찾아 그 아래만 읽고, 딕셔너리로 중복 제거합니다.

사용 방법(3단계)

1. 엑셀에서 ALT + F11 → VBA 편집기
2. 삽입(Insert) > 모듈(Module)
3. 아래 코드 붙여넣기 → Consolidate_Names_To_Ace 실행 (H1 셀의 만들어 놓은 매크로 버튼 클릭)

엑셀 - 매크로(VBA) 적용 후

VBA 코드

Option Explicit

Public Sub Consolidate_Names_To_Ace()
    Dim targetWs As Worksheet
    Set targetWs = ThisWorkbook.Worksheets("Summary")

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbBinaryCompare  '한글은 대소문자 이슈 거의 없음

    On Error GoTo SafeExit
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    '기존 결과 삭제 (C4:D 아래)
    Dim lastOut As Long
    lastOut = targetWs.Cells(targetWs.Rows.Count, "D").End(xlUp).Row
    If lastOut < 4 Then lastOut = 4
    targetWs.Range("C4:D" & lastOut).ClearContents

    Dim outRow As Long
    outRow = 4

    outRow = AppendFromSheet(targetWs, outRow, dict, "1차", "F", "성명")
    outRow = AppendFromSheet(targetWs, outRow, dict, "2차", "F", "성명")
    outRow = AppendFromSheet(targetWs, outRow, dict, "3차", "B", "성명")

SafeExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Function AppendFromSheet(ByVal targetWs As Worksheet, ByVal outRow As Long, _
                                 ByVal dict As Object, ByVal srcSheetName As String, _
                                 ByVal srcColLetter As String, ByVal headerText As String) As Long
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(srcSheetName)

    Dim col As Long
    col = ws.Range(srcColLetter & "1").Column

    Dim headerRow As Variant
    headerRow = FindHeaderRow(ws, col, headerText)
    If IsError(headerRow) Then
        AppendFromSheet = outRow
        Exit Function
    End If

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
    If lastRow <= CLng(headerRow) Then
        AppendFromSheet = outRow
        Exit Function
    End If

    Dim arr As Variant
    arr = ws.Range(ws.Cells(CLng(headerRow) + 1, col), ws.Cells(lastRow, col)).Value2

    Dim temp() As String
    Dim n As Long: n = 0

    Dim i As Long
    For i = 1 To UBound(arr, 1)
        Dim s As String
        s = Trim$(CStr(arr(i, 1)))

        If s = "" Then Exit For
        If InStr(1, s, "합", vbTextCompare) > 0 Or InStr(1, s, "총", vbTextCompare) > 0 Then Exit For

        If IsNameLike(s) Then
            If Not dict.Exists(s) Then
                dict.Add s, True
                n = n + 1
                ReDim Preserve temp(1 To n)
                temp(n) = s
            End If
        End If
    Next i

    If n = 0 Then
        AppendFromSheet = outRow
        Exit Function
    End If

    '2열(시트명/이름)로 한 번에 써서 속도 확보
    Dim outArr() As Variant
    ReDim outArr(1 To n, 1 To 2)

    For i = 1 To n
        If i = 1 Then outArr(i, 1) = srcSheetName Else outArr(i, 1) = ""
        outArr(i, 2) = temp(i)
    Next i

    targetWs.Range(targetWs.Cells(outRow, "C"), targetWs.Cells(outRow + n - 1, "D")).Value = outArr
    AppendFromSheet = outRow + n
End Function

Private Function FindHeaderRow(ByVal ws As Worksheet, ByVal col As Long, ByVal headerText As String) As Variant
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row

    Dim r As Long
    For r = 1 To lastRow
        Dim v As Variant
        v = ws.Cells(r, col).Value

        If VarType(v) = vbString Then
            If Trim$(CStr(v)) = headerText Then
                FindHeaderRow = r
                Exit Function
            End If
        End If
    Next r

    FindHeaderRow = CVErr(xlErrNA)
End Function

Private Function IsNameLike(ByVal s As String) As Boolean
    s = Trim$(s)
    If Len(s) < 2 Or Len(s) > 20 Then IsNameLike = False: Exit Function
    If s Like "*[0-9]*" Then IsNameLike = False: Exit Function
    If InStr(1, s, "=", vbTextCompare) > 0 Then IsNameLike = False: Exit Function
    If Not (s Like "*[가-힣]*") Then IsNameLike = False: Exit Function

    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^[가-힣\s]{2,20}$"   '한글 이름(공백 포함 가능)
    re.Global = False

    IsNameLike = re.Test(s)
End Function

근거(왜 VBA가 대용량에 유리한가)

• 셀을 한 개씩 계산/스필하는 방식이 아니라, 범위를 배열로 읽고(Variant Array) → 딕셔너리로 중복 제거 → 한 번에 Range에 써서 속도가 빠릅니다.

엑셀 - 각 시트에서 이름불러오기.xlsm

0.94MB