VBA 스나이퍼

Branch_Sales_Search_System.xlsm

VBA Scripting.Dictionary 완전 정복 ️

노만e — Sun, 22 Mar 2026 14:49:58 +0900

1. Dictionary란 무엇인가?

Dictionary는 "열쇠(Key)"와 "값(Value)"을 쌍으로 저장하는 메모리 저장소입니다.

우리가 일상에서 사용하는 사전(단어장) 과 똑같은 원리입니다.

영어사전에서 "apple"을 찾으면 → "사과"가 나오듯이 Dictionary에서 "apple"을 찾으면 → 저장해둔 값이 즉시 나옵니다.

┌─────────────────────────────────────────┐
│           Scripting.Dictionary          │
│                                         │
│  Key(열쇠)      Value(값)               │
│  ──────────     ──────────              │
│  "김치찌개"  →  8000                   │
│  "된장찌개"  →  7000                   │
│  "비빔밥"    →  9000                   │
│                                         │
│  찾는 방법: dict("김치찌개") → 8000    │
└─────────────────────────────────────────┘

2. 왜 Dictionary를 사용해야 하는가?

Dictionary 없이 — 반복문 탐색 (느림)

데이터가 많아질수록 속도가 급격히 느려집니다. 예를 들어 Message 시트에 10,000행, Fault Type 시트에 500행이 있다면 최악의 경우 10,000 × 500 = 5,000,000번 비교해야 합니다.

' ❌ 느린 방식 - 매번 처음부터 끝까지 탐색
For i = 1 To 10000          ' Message 시트 행
    For j = 1 To 500        ' Fault Type 시트 행
        If msgData(i) = faultData(j) Then
            result(i) = faultType(j)
            Exit For
        End If
    Next j
Next i
' 최악의 경우 5,000,000번 비교 발생!

Dictionary 사용 — 즉시 탐색 (빠름)

Dictionary는 처음 한 번만 데이터를 등록해두면, 이후 검색은 단 1번으로 끝납니다.

' ✅ 빠른 방식 - Key로 즉시 탐색
For i = 1 To 10000          ' Message 시트 행만큼만 반복
    result(i) = dict(msgData(i))   ' 단 1번 검색!
Next i
' 10,000번만 실행! 속도 차이 수십~수백 배

속도 비교표

구분Message 행Fault Type 행최대 비교 횟수

반복문 방식	10,000	500	5,000,000번
Dictionary 방식	10,000	500	10,000번
속도 차이			약 500배 빠름

3. Dictionary 메서드 완전 정리

생성 및 설정

' Dictionary 생성
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

' 대소문자 설정
dict.CompareMode = vbTextCompare    ' 대소문자 무시 (A = a)
dict.CompareMode = vbBinaryCompare  ' 대소문자 구분 (A ≠ a) ← 기본값

핵심 메서드 6가지

① Add — 항목 추가

dict.Add Key, Value

dict.Add "김치찌개", 8000
dict.Add "된장찌개", 7000
' ※ 중복 Key 추가 시 오류 발생!

② Exists — Key 존재 여부 확인

dict.Exists(Key)  ' True / False 반환

If dict.Exists("김치찌개") Then
    MsgBox "있음! → " & dict("김치찌개")  ' 8000
Else
    MsgBox "없음 → etc 처리"
End If

③ Remove — 특정 항목 삭제

dict.Remove Key

dict.Remove "김치찌개"   ' 김치찌개 항목만 삭제

④ RemoveAll — 전체 삭제

dict.RemoveAll   ' 모든 항목 삭제

⑤ Keys — 전체 Key 목록

Dim keys As Variant
keys = dict.Keys   ' 배열로 반환

Dim i As Long
For i = 0 To UBound(keys)
    Debug.Print keys(i)   ' 김치찌개, 된장찌개, 비빔밥
Next i

⑥ Items — 전체 Value 목록

Dim vals As Variant
vals = dict.Items  ' 배열로 반환

For i = 0 To UBound(vals)
    Debug.Print vals(i)   ' 8000, 7000, 9000
Next i

속성

dict.Count   ' 저장된 항목 수 반환
' → 3

전체 메서드 요약표

메서드 / 속성사용법설명

.Add	dict.Add Key, Value	항목 추가
.Exists	dict.Exists(Key)	Key 존재 여부 확인
.Remove	dict.Remove Key	특정 항목 삭제
.RemoveAll	dict.RemoveAll	전체 삭제
.Count	dict.Count	항목 개수 반환
.Keys	dict.Keys	전체 Key 배열 반환
.Items	dict.Items	전체 Value 배열 반환

4. 기본 예제 코드

Sub Dictionary_Basic()

    '==========================================================
    ' Step 1. Dictionary 생성
    '==========================================================
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare  ' 대소문자 무시

    '==========================================================
    ' Step 2. 데이터 추가 (Add)
    '==========================================================
    dict.Add "김치찌개", 8000
    dict.Add "된장찌개", 7000
    dict.Add "비빔밥",   9000
    dict.Add "냉면",     10000

    Debug.Print "▶ 항목 수: " & dict.Count   ' → 4

    '==========================================================
    ' Step 3. 값 읽기
    '==========================================================
    Debug.Print "▶ 김치찌개: " & dict("김치찌개")  ' → 8000

    '==========================================================
    ' Step 4. 존재 여부 확인 후 읽기 (Exists - 안전한 방법!)
    '==========================================================
    If dict.Exists("냉면") Then
        Debug.Print "▶ 냉면: " & dict("냉면")      ' → 10000
    Else
        Debug.Print "▶ 없음 → etc"
    End If

    If dict.Exists("삼겹살") Then
        Debug.Print "▶ 삼겹살: " & dict("삼겹살")
    Else
        Debug.Print "▶ 없음 → etc"                 ' ← 이쪽 실행
    End If

    '==========================================================
    ' Step 5. 값 수정
    '==========================================================
    dict("김치찌개") = 9500
    Debug.Print "▶ 수정 후: " & dict("김치찌개")   ' → 9500

    '==========================================================
    ' Step 6. 특정 항목 삭제
    '==========================================================
    dict.Remove "냉면"
    Debug.Print "▶ 삭제 후 항목 수: " & dict.Count ' → 3

    '==========================================================
    ' Step 7. 전체 Key / Value 출력
    '==========================================================
    Dim k As Variant
    For Each k In dict.Keys
        Debug.Print "  " & k & " → " & dict(k)
    Next k

    '==========================================================
    ' Step 8. 메모리 해제 (필수!)
    '==========================================================
    Set dict = Nothing

    MsgBox "완료! Ctrl+G 로 결과 확인", vbInformation

End Sub

5. 실전 예제 — Fault Type 자동 분류

아래는 실제 업무에 적용한 예제입니다. Message 시트의 오류 메시지(G열) 를 읽어서 Fault Type 시트 와 매칭한 뒤, P열에 분류값을 자동으로 입력하는 코드입니다.

예제 파일 구조

[Message 시트]

A열...G열 (LONGTEXT)...P열 (결과)

2020-03-01	...	Overlength fault	...	← 여기에 자동입력
2020-03-01	...	Workplace occupied	...	← 여기에 자동입력
2020-03-01	...	Timeout stop mode	...	← 여기에 자동입력

[Fault Type 시트]

A열 (LongText)B열 (Type)

Overlength fault	Sensor Fault
Workplace occupied	Operator
Timeout stop mode	Mechanical

전체 코드

Sub AddFaultType()

    '==========================================================
    ' 변수 선언
    '==========================================================
    Dim wsMessage   As Worksheet    ' Message 시트
    Dim wsFaultType As Worksheet    ' Fault Type 시트
    Dim lastRowMsg  As Long         ' Message 시트 마지막 행
    Dim lastRowFault As Long        ' Fault Type 시트 마지막 행
    Dim dictFault   As Object       ' Dictionary 객체
    Dim i           As Long         ' 반복문 카운터
    Dim startTime   As Double       ' 시작 시간 (처리 속도 측정용)

    startTime = Timer               ' 시작 시간 기록

    '==========================================================
    ' Step 1. 시트 연결
    '==========================================================
    Set wsMessage   = ThisWorkbook.Sheets("Message")
    Set wsFaultType = ThisWorkbook.Sheets("Fault Type")

    '==========================================================
    ' Step 2. 마지막 행 찾기
    '==========================================================
    lastRowMsg   = wsMessage.Cells(wsMessage.Rows.Count, "G").End(xlUp).Row
    lastRowFault = wsFaultType.Cells(wsFaultType.Rows.Count, "A").End(xlUp).Row

    '==========================================================
    ' Step 3. 화면 업데이트 비활성화 (속도 향상 핵심!)
    '  - ScreenUpdating : 화면 갱신 중지
    '  - Calculation    : 자동 계산 중지
    '  - EnableEvents   : 이벤트 중지
    '==========================================================
    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual
    Application.EnableEvents   = False

    '==========================================================
    ' Step 4. Dictionary 생성 및 Fault Type 데이터 로드
    '  - Fault Type 시트 A열(Key) → B열(Value) 매핑
    '  - 한 번만 읽어서 메모리에 저장
    '==========================================================
    Set dictFault = CreateObject("Scripting.Dictionary")
    dictFault.CompareMode = vbTextCompare  ' 대소문자 무시

    Dim faultKeys As Variant
    Dim faultVals As Variant

    ' 배열로 한 번에 읽기 (시트 접근 최소화)
    faultKeys = wsFaultType.Range("A2:A" & lastRowFault).Value
    faultVals = wsFaultType.Range("B2:B" & lastRowFault).Value

    ' Dictionary에 등록
    Dim key As String
    For i = 1 To UBound(faultKeys, 1)
        key = Trim(CStr(faultKeys(i, 1)))
        ' 빈 값 제외, 중복 Key 제외
        If key <> "" And Not dictFault.Exists(key) Then
            dictFault.Add key, CStr(faultVals(i, 1))
        End If
    Next i

    '==========================================================
    ' Step 5. Message 시트 G열 데이터를 배열로 읽기
    '  - 셀 하나씩 읽지 않고 배열로 한 번에 읽어 속도 향상
    '==========================================================
    Dim msgData As Variant
    msgData = wsMessage.Range("G2:G" & lastRowMsg).Value

    '==========================================================
    ' Step 6. 결과 배열 생성 및 매칭 처리
    '  - Dictionary로 즉시 검색
    '  - 매칭 없으면 "etc" 입력
    '==========================================================
    Dim resultArr  As Variant
    Dim lookupKey  As String
    ReDim resultArr(1 To UBound(msgData, 1), 1 To 1)

    For i = 1 To UBound(msgData, 1)
        lookupKey = Trim(CStr(msgData(i, 1)))
        If dictFault.Exists(lookupKey) Then
            resultArr(i, 1) = dictFault(lookupKey)  ' 매칭 성공
        Else
            resultArr(i, 1) = "etc"                 ' 매칭 실패 → etc
        End If
    Next i

    '==========================================================
    ' Step 7. 결과를 P열에 한 번에 쓰기
    '  - 셀 하나씩 쓰지 않고 배열로 한 번에 입력 (속도 핵심!)
    '==========================================================
    wsMessage.Cells(1, "P").Value = "Fault Type"    ' 헤더
    wsMessage.Range("P2:P" & lastRowMsg).Value = resultArr

    '==========================================================
    ' Step 8. 화면 업데이트 복원 (반드시 복원!)
    '==========================================================
    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.EnableEvents   = True

    '==========================================================
    ' Step 9. 결과 통계 계산 및 완료 메시지
    '==========================================================
    Dim etcCount   As Long
    Dim matchCount As Long

    For i = 1 To UBound(resultArr, 1)
        If resultArr(i, 1) = "etc" Then
            etcCount = etcCount + 1
        Else
            matchCount = matchCount + 1
        End If
    Next i

    MsgBox "✅ 처리 완료!" & vbNewLine & vbNewLine & _
           "⏱ 처리 시간    : " & Format(Timer - startTime, "0.00") & "초" & vbNewLine & _
           "  총 처리 행   : " & Format(lastRowMsg - 1, "#,##0") & "행" & vbNewLine & _
           "✔ 매칭 성공    : " & Format(matchCount, "#,##0") & "행" & vbNewLine & _
           "❌ 매칭 실패(etc): " & Format(etcCount, "#,##0") & "행" & vbNewLine & _
           "  Fault Type 수 : " & dictFault.Count & "개", _
           vbInformation, "Fault Type 추가 완료"

    '==========================================================
    ' Step 10. 메모리 해제 (사용한 객체 반드시 해제!)
    '==========================================================
    Set dictFault   = Nothing
    Set wsMessage   = Nothing
    Set wsFaultType = Nothing

End Sub

6. 전체 처리 흐름 요약

[Fault Type 시트]         [Dictionary]            [Message 시트]
  A열      B열             (메모리 저장)            G열    →    P열
──────────────────    ───────────────────────    ────────────────────
Overlength Sensor  →  "Overlength" : "Sensor"   Overlength → Sensor
Jam fault  Mech    →  "Jam fault"  : "Mech"     Jam fault  → Mech
Timeout    Elec    →  "Timeout"    : "Elec"     알수없는값  → etc
                      ↑                          ↑
                  1회만 읽어 등록          즉시 검색 후 배열로 한번에 쓰기

✅ 핵심 요약 3가지

Dictionary는 Key-Value 구조의 메모리 저장소로 즉시 탐색(O(1)) 이 가능합니다
반복문 이중 탐색 대비 수십~수백 배 빠른 속도를 제공합니다
배열 일괄 읽기/쓰기 와 함께 사용하면 대용량 데이터도 수초 내 처리가 가능합니다

Excel VBA 지점별 매출 통합 검색 시스템 완벽 가이드

노만e — Sun, 4 Jan 2026 19:50:05 +0900

들어가며

엑셀로 여러 지점의 매출 데이터를 관리하다 보면, 각 시트에 흩어진 정보를 일일이 찾아보는 것이 매우 번거롭습니다. 이번 글에서는 VBA를 활용하여 여러 시트에 분산된 데이터를 한 번에 검색하고, 제품별·지역별·지점별 통계를 자동으로 생성하는 강력한 통합 검색 시스템을 소개합니다. 특히 VBA에서 자주 발생하는 런타임 오류 13번(형식 불일치) 문제를 해결한 안정적인 코드입니다.

시스템 개요

이 시스템은 총 6개의 주요 기능으로 구성되어 있습니다:

통합 검색: 모든 지점 시트에서 조건에 맞는 데이터를 한 번에 검색
제품별 통계: 검색 결과를 기반으로 제품별 판매량과 매출 집계
지역별 통계: 지역별 판매 현황 분석
지점별 통계: 각 지점의 실적 비교
검색 조건 초기화: 입력된 검색 조건을 한 번에 삭제
통계 대시보드: 전체 매출 현황을 한눈에 보여주는 요약 화면

1. 통합 검색 기능

기능 설명

통합 검색 기능은 워크북 내 모든 시트를 순회하며 사용자가 입력한 조건(제품명, 지역, 지점, 기간)에 맞는 데이터를 찾아 '검색결과' 시트에 자동으로 정리합니다. 검색 속도를 높이기 위해 화면 업데이트를 중지하고, 자동 계산 기능을 일시적으로 비활성화하는 최적화 기법을 적용했습니다.

주요 코드

Sub 통합검색()
    Dim wsMenu As Worksheet
    Dim wsResult As Worksheet
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim resultRow As Long
    Dim i As Long
    
    ' 검색 조건 변수
    Dim searchProduct As String
    Dim searchRegion As String
    Dim searchBranch As String
    Dim searchStartDate As String
    Dim searchEndDate As String
    Dim startDate As Date
    Dim endDate As Date
    
    ' 검색 조건 읽기
    Set wsMenu = ThisWorkbook.Sheets("검색메뉴")
    searchProduct = Trim(wsMenu.Range("C5").Value)
    searchRegion = Trim(wsMenu.Range("C6").Value)
    searchBranch = Trim(wsMenu.Range("C7").Value)
    searchStartDate = Trim(wsMenu.Range("C8").Value)
    searchEndDate = Trim(wsMenu.Range("C9").Value)
    
    ' 날짜 변환
    Dim useStartDate As Boolean, useEndDate As Boolean
    useStartDate = False
    useEndDate = False
    
    If searchStartDate <> "" Then
        If IsDate(searchStartDate) Then
            startDate = CDate(searchStartDate)
            useStartDate = True
        End If
    End If
    
    If searchEndDate <> "" Then
        If IsDate(searchEndDate) Then
            endDate = CDate(searchEndDate)
            useEndDate = True
        End If
    End If
    
    ' 검색결과 시트 초기화
    Set wsResult = ThisWorkbook.Sheets("검색결과")
    wsResult.Rows("2:" & wsResult.Rows.Count).Delete
    resultRow = 2
    
    ' 화면 업데이트 중지 (속도 향상)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 모든 지점 시트 검색
    For Each ws In ThisWorkbook.Worksheets
        ' 검색메뉴와 검색결과 시트는 제외
        If ws.Name <> "검색메뉴" And ws.Name <> "검색결과" Then
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            
            ' 데이터가 있는 경우만 처리 (헤더 제외)
            If lastRow > 1 Then
                For i = 2 To lastRow
                    Dim matchProduct As Boolean
                    Dim matchRegion As Boolean
                    Dim matchBranch As Boolean
                    Dim matchDate As Boolean
                    
                    ' 각 조건 확인
                    matchProduct = (searchProduct = "" Or InStr(1, ws.Cells(i, 3).Value, searchProduct, vbTextCompare) > 0)
                    matchRegion = (searchRegion = "" Or InStr(1, ws.Cells(i, 4).Value, searchRegion, vbTextCompare) > 0)
                    matchBranch = (searchBranch = "" Or InStr(1, ws.Cells(i, 2).Value, searchBranch, vbTextCompare) > 0)
                    
                    ' 날짜 조건 확인
                    matchDate = True
                    If useStartDate Or useEndDate Then
                        If IsDate(ws.Cells(i, 1).Value) Then
                            Dim cellDate As Date
                            cellDate = CDate(ws.Cells(i, 1).Value)
                            
                            If useStartDate And cellDate < startDate Then
                                matchDate = False
                            End If
                            
                            If useEndDate And cellDate > endDate Then
                                matchDate = False
                            End If
                        End If
                    End If
                    
                    ' 모든 조건이 맞으면 결과에 추가
                    If matchProduct And matchRegion And matchBranch And matchDate Then
                        ' 데이터 복사
                        ws.Rows(i).Copy Destination:=wsResult.Rows(resultRow)
                        resultRow = resultRow + 1
                    End If
                Next i
            End If
        End If
    Next ws
    
    ' 화면 업데이트 재개
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    ' 결과 표시
    Dim resultCount As Long
    resultCount = resultRow - 2
    
    If resultCount > 0 Then
        MsgBox resultCount & "건의 데이터를 찾았습니다!" & vbCrLf & _
               "검색결과 시트를 확인하세요.", vbInformation, "검색 완료"
        wsResult.Activate
    Else
        MsgBox "검색 조건에 맞는 데이터가 없습니다.", vbExclamation, "검색 결과 없음"
    End If
End Sub

코드 설명

코드의 핵심은 크게 세 단계로 나뉩니다. 첫 번째로 '검색메뉴' 시트에서 사용자가 입력한 검색 조건을 읽어옵니다. 이때 날짜 데이터는 IsDate 함수로 유효성을 검증한 후 CDate 함수로 변환합니다. 두 번째로 워크북의 모든 시트를 순회하면서 각 행의 데이터가 검색 조건과 일치하는지 확인합니다. InStr 함수를 사용하여 부분 일치 검색을 지원하며, vbTextCompare 옵션으로 대소문자를 구분하지 않습니다. 세 번째로 조건에 맞는 행을 '검색결과' 시트에 복사하고, 최종적으로 몇 건의 데이터를 찾았는지 메시지로 알려줍니다.

2. 제품별 통계 기능

기능 설명

제품별 통계 기능은 검색 결과를 바탕으로 각 제품의 총 판매량, 매출액, 평균 단가를 계산합니다. 이전 버전에서는 Dictionary 배열 요소를 직접 수정하려 할 때 런타임 오류 13번(형식 불일치)이 발생했는데, 이를 임시 변수에 값을 저장한 후 새로운 배열로 교체하는 방식으로 완벽히 해결했습니다.

주요 코드

Sub 제품별통계()
    Dim wsResult As Worksheet
    Dim wsStats As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim product As String
    Dim amount As Double
    Dim quantity As Long
    
    ' 검색결과가 있는지 확인
    Set wsResult = ThisWorkbook.Sheets("검색결과")
    lastRow = wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Row
    
    If lastRow < 2 Then
        MsgBox "검색결과가 없습니다. 먼저 검색을 실행하세요.", vbExclamation
        Exit Sub
    End If
    
    ' Dictionary 객체 생성
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 제품별 집계 - 수정된 방식
    For i = 2 To lastRow
        product = wsResult.Cells(i, 3).Value  ' 제품명
        quantity = wsResult.Cells(i, 5).Value  ' 수량
        amount = wsResult.Cells(i, 7).Value    ' 총액
        
        If dict.Exists(product) Then
            ' 기존 값을 임시 변수에 저장
            Dim tempQty As Long
            Dim tempAmt As Double
            tempQty = dict(product)(0)
            tempAmt = dict(product)(1)
            
            ' 새로운 배열로 교체
            dict(product) = Array(tempQty + quantity, tempAmt + amount)
        Else
            dict.Add product, Array(quantity, amount)
        End If
    Next i
    
    ' 통계 시트 생성 또는 초기화
    On Error Resume Next
    Set wsStats = ThisWorkbook.Sheets("제품별통계")
    If wsStats Is Nothing Then
        Set wsStats = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsStats.Name = "제품별통계"
    Else
        wsStats.Cells.Clear
    End If
    On Error GoTo 0
    
    ' 헤더 작성
    wsStats.Range("A1").Value = "제품명"
    wsStats.Range("B1").Value = "판매수량"
    wsStats.Range("C1").Value = "매출액"
    wsStats.Range("D1").Value = "평균단가"
    
    ' 헤더 서식
    With wsStats.Range("A1:D1")
        .Font.Bold = True
        .Interior.Color = RGB(68, 114, 196)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With
    
    ' 데이터 작성
    Dim Row As Long
    Dim key As Variant
    Row = 2
    
    For Each key In dict.Keys
        wsStats.Cells(Row, 1).Value = key
        wsStats.Cells(Row, 2).Value = dict(key)(0)
        wsStats.Cells(Row, 3).Value = dict(key)(1)
        wsStats.Cells(Row, 4).Value = dict(key)(1) / dict(key)(0)
        Row = Row + 1
    Next key
    
    ' 열 너비 자동 조정
    wsStats.Columns("A:D").AutoFit
    
    ' 숫자 서식
    wsStats.Range("B2:B" & Row - 1).NumberFormat = "#,##0"
    wsStats.Range("C2:D" & Row - 1).NumberFormat = "#,##0"
    
    wsStats.Activate
    MsgBox "제품별 통계가 생성되었습니다!", vbInformation
End Sub

3. 지역별 통계 기능

기능 설명

지역별 통계는 제품별 통계와 유사한 방식으로 작동하지만, 집계 기준이 지역(4번 열)이 됩니다. 각 지역의 총 판매량과 매출액을 계산하여 지역별 실적을 비교할 수 있습니다.

주요 코드

Sub 지역별통계()
    Dim wsResult As Worksheet
    Dim wsStats As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim region As String
    Dim amount As Double
    Dim quantity As Long
    
    ' 검색결과가 있는지 확인
    Set wsResult = ThisWorkbook.Sheets("검색결과")
    lastRow = wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Row
    
    If lastRow < 2 Then
        MsgBox "검색결과가 없습니다. 먼저 검색을 실행하세요.", vbExclamation
        Exit Sub
    End If
    
    ' Dictionary 객체 생성
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 지역별 집계 - 수정된 방식 (오류 해결)
    For i = 2 To lastRow
        region = wsResult.Cells(i, 4).Value    ' 지역
        quantity = wsResult.Cells(i, 5).Value  ' 수량
        amount = wsResult.Cells(i, 7).Value    ' 총액
        
        If dict.Exists(region) Then
            ' ★ 수정: 기존 값을 임시 변수에 저장 후 새로운 배열로 교체
            Dim tempQty As Long
            Dim tempAmt As Double
            tempQty = dict(region)(0)
            tempAmt = dict(region)(1)
            
            ' 새로운 배열로 교체 (기존 배열을 직접 수정하지 않음)
            dict(region) = Array(tempQty + quantity, tempAmt + amount)
        Else
            dict.Add region, Array(quantity, amount)
        End If
    Next i
    
    ' 통계 시트 생성 또는 초기화
    On Error Resume Next
    Set wsStats = ThisWorkbook.Sheets("지역별통계")
    If wsStats Is Nothing Then
        Set wsStats = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsStats.Name = "지역별통계"
    Else
        wsStats.Cells.Clear
    End If
    On Error GoTo 0
    
    ' 헤더 작성
    wsStats.Range("A1").Value = "지역"
    wsStats.Range("B1").Value = "판매수량"
    wsStats.Range("C1").Value = "매출액"
    
    ' 헤더 서식
    With wsStats.Range("A1:C1")
        .Font.Bold = True
        .Interior.Color = RGB(112, 173, 71)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With
    
    ' 데이터 작성
    Dim Row As Long
    Dim key As Variant
    Row = 2
    
    For Each key In dict.Keys
        wsStats.Cells(Row, 1).Value = key
        wsStats.Cells(Row, 2).Value = dict(key)(0)
        wsStats.Cells(Row, 3).Value = dict(key)(1)
        Row = Row + 1
    Next key
    
    ' 열 너비 자동 조정
    wsStats.Columns("A:C").AutoFit
    
    ' 숫자 서식
    wsStats.Range("B2:B" & Row - 1).NumberFormat = "#,##0"
    wsStats.Range("C2:C" & Row - 1).NumberFormat = "#,##0"
    
    wsStats.Activate
    MsgBox "지역별 통계가 생성되었습니다!", vbInformation
End Sub

4. 지점별 통계 기능

기능 설명

지점별 통계는 각 지점(2번 열)의 판매 실적을 집계합니다. 어떤 지점이 가장 많이 팔았는지, 어느 지점의 매출이 높은지를 한눈에 파악할 수 있어 실적 관리에 유용합니다.

주요 코드

Sub 지점별통계()
    Dim wsResult As Worksheet
    Dim wsStats As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim branch As String
    Dim amount As Double
    Dim quantity As Long
    
    ' 검색결과가 있는지 확인
    Set wsResult = ThisWorkbook.Sheets("검색결과")
    lastRow = wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Row
    
    If lastRow < 2 Then
        MsgBox "검색결과가 없습니다. 먼저 검색을 실행하세요.", vbExclamation
        Exit Sub
    End If
    
    ' Dictionary 객체 생성
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 지점별 집계
    For i = 2 To lastRow
        branch = wsResult.Cells(i, 2).Value    ' 지점
        quantity = wsResult.Cells(i, 5).Value  ' 수량
        amount = wsResult.Cells(i, 7).Value    ' 총액
        
        If dict.Exists(branch) Then
            Dim tempQty As Long
            Dim tempAmt As Double
            tempQty = dict(branch)(0)
            tempAmt = dict(branch)(1)
            dict(branch) = Array(tempQty + quantity, tempAmt + amount)
        Else
            dict.Add branch, Array(quantity, amount)
        End If
    Next i
    
    ' 통계 시트 생성 또는 초기화
    On Error Resume Next
    Set wsStats = ThisWorkbook.Sheets("지점별통계")
    If wsStats Is Nothing Then
        Set wsStats = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsStats.Name = "지점별통계"
    Else
        wsStats.Cells.Clear
    End If
    On Error GoTo 0
    
    ' 헤더 작성
    wsStats.Range("A1").Value = "지점"
    wsStats.Range("B1").Value = "판매수량"
    wsStats.Range("C1").Value = "매출액"
    
    ' 헤더 서식
    With wsStats.Range("A1:C1")
        .Font.Bold = True
        .Interior.Color = RGB(237, 125, 49)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With
    
    ' 데이터 작성
    Dim Row As Long
    Dim key As Variant
    Row = 2
    
    For Each key In dict.Keys
        wsStats.Cells(Row, 1).Value = key
        wsStats.Cells(Row, 2).Value = dict(key)(0)
        wsStats.Cells(Row, 3).Value = dict(key)(1)
        Row = Row + 1
    Next key
    
    ' 열 너비 자동 조정
    wsStats.Columns("A:C").AutoFit
    
    ' 숫자 서식
    wsStats.Range("B2:B" & Row - 1).NumberFormat = "#,##0"
    wsStats.Range("C2:C" & Row - 1).NumberFormat = "#,##0"
    
    wsStats.Activate
    MsgBox "지점별 통계가 생성되었습니다!", vbInformation
End Sub

5. 검색 조건 초기화

기능 설명

검색 조건 초기화는 간단하지만 매우 유용한 기능입니다. '검색메뉴' 시트의 C5:C9 범위(제품명, 지역, 지점, 시작일, 종료일)에 입력된 모든 값을 한 번에 지워줍니다.

주요 코드

Sub 검색조건초기화()
    Dim wsMenu As Worksheet
    Set wsMenu = ThisWorkbook.Sheets("검색메뉴")
    
    wsMenu.Range("C5:C9").ClearContents
    MsgBox "검색 조건이 초기화되었습니다.", vbInformation
End Sub

6. 전체 통계 대시보드

기능 설명

전체 통계 대시보드는 검색 결과의 전체적인 현황을 요약해서 보여줍니다. 총 거래 건수, 총 판매 수량, 총 매출액, 평균 거래 금액을 자동으로 계산하여 깔끔한 형태로 표시합니다.

주요 코드

Sub 전체통계대시보드()
    Dim wsResult As Worksheet
    Dim wsDash As Worksheet
    Dim lastRow As Long
    Dim totalQty As Long
    Dim totalAmt As Double
    Dim avgAmt As Double
    
    ' 검색결과가 있는지 확인
    Set wsResult = ThisWorkbook.Sheets("검색결과")
    lastRow = wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Row
    
    If lastRow < 2 Then
        MsgBox "검색결과가 없습니다. 먼저 검색을 실행하세요.", vbExclamation
        Exit Sub
    End If
    
    ' 합계 계산
    totalQty = Application.WorksheetFunction.Sum(wsResult.Range("E2:E" & lastRow))
    totalAmt = Application.WorksheetFunction.Sum(wsResult.Range("G2:G" & lastRow))
    avgAmt = totalAmt / (lastRow - 1)
    
    ' 대시보드 시트 생성
    On Error Resume Next
    Set wsDash = ThisWorkbook.Sheets("통계대시보드")
    If wsDash Is Nothing Then
        Set wsDash = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsDash.Name = "통계대시보드"
    Else
        wsDash.Cells.Clear
    End If
    On Error GoTo 0
    
    ' 제목
    wsDash.Range("B2").Value = "  매출 통계 대시보드"
    wsDash.Range("B2").Font.Size = 16
    wsDash.Range("B2").Font.Bold = True
    
    ' 요약 정보
    wsDash.Range("B4").Value = "총 거래 건수:"
    wsDash.Range("C4").Value = lastRow - 1
    wsDash.Range("C4").NumberFormat = "#,##0"
    
    wsDash.Range("B5").Value = "총 판매 수량:"
    wsDash.Range("C5").Value = totalQty
    wsDash.Range("C5").NumberFormat = "#,##0"
    
    wsDash.Range("B6").Value = "총 매출액:"
    wsDash.Range("C6").Value = totalAmt
    wsDash.Range("C6").NumberFormat = "#,##0"
    
    wsDash.Range("B7").Value = "평균 거래금액:"
    wsDash.Range("C7").Value = avgAmt
    wsDash.Range("C7").NumberFormat = "#,##0"
    
    ' 서식
    wsDash.Range("B4:B7").Font.Bold = True
    wsDash.Range("C4:C7").Interior.Color = RGB(217, 225, 242)
    wsDash.Columns("B:C").AutoFit
    
    wsDash.Activate
    MsgBox "통계 대시보드가 생성되었습니다!", vbInformation
End Sub

시스템 사용 방법

1단계: 워크북 구조 준비

이 시스템이 제대로 작동하려면 다음과 같은 시트 구조가 필요합니다:

검색메뉴 시트: C5(제품명), C6(지역), C7(지점), C8(시작일), C9(종료일) 셀에 검색 조건을 입력합니다
검색결과 시트: 검색된 데이터가 자동으로 저장됩니다
각 지점 시트: 1열(날짜), 2열(지점), 3열(제품명), 4열(지역), 5열(수량), 7열(총액) 형식으로 데이터가 정리되어 있어야 합니다

2단계: VBA 코드 입력

엑셀에서 Alt + F11을 눌러 VBA 편집기를 열고, 삽입 메뉴에서 '모듈'을 추가한 후 위의 코드를 모두 복사해서 붙여넣습니다.

3단계: 매크로 실행

개발 도구 탭의 매크로 버튼을 클릭하거나, Alt + F8을 눌러 원하는 기능을 선택하여 실행합니다. 권장 실행 순서는 다음과 같습니다:

먼저 '통합검색'을 실행하여 원하는 데이터를 찾습니다
그 다음 '제품별통계', '지역별통계', '지점별통계' 중 필요한 것을 실행합니다
전체 현황이 궁금하면 '전체통계대시보드'를 실행합니다
새로운 검색을 하려면 '검색조건초기화'로 조건을 지운 후 다시 시작합니다

핵심 기술 설명

Dictionary 객체 활용

이 시스템의 핵심은 Scripting.Dictionary 객체입니다. Dictionary는 키(Key)와 값(Value)의 쌍으로 데이터를 저장하는 자료구조로, 배열보다 훨씬 빠르고 효율적으로 데이터를 검색하고 집계할 수 있습니다. 제품명이나 지역명을 키로 사용하고, 수량과 금액을 배열로 저장하여 중복 없이 데이터를 누적합니다.

성능 최적화

대량의 데이터를 처리할 때는 Application.ScreenUpdating = False로 화면 갱신을 중지하고, Application.Calculation = xlCalculationManual로 자동 계산을 비활성화하는 것이 매우 중요합니다. 이 두 가지만으로도 실행 속도가 수십 배 향상될 수 있습니다. 작업이 끝나면 반드시 다시 활성화해야 합니다.

오류 처리

On Error Resume Next를 활용하여 시트가 이미 존재하는지 확인하고, 없으면 새로 만들고 있으면 내용을 지우는 방식으로 처리합니다. 또한 검색 결과가 없을 때는 통계 기능을 실행하지 못하도록 사전에 검증하여 오류를 방지합니다.

응용 및 확장 아이디어

이 시스템을 기반으로 다음과 같은 기능을 추가할 수 있습니다:

차트 자동 생성: 통계 결과를 바탕으로 막대 그래프나 원형 차트를 자동으로 생성하면 시각적인 분석이 가능합니다
엑셀 파일로 내보내기: 검색 결과나 통계를 별도의 엑셀 파일로 저장하는 기능을 추가하면 보고서 작성이 편리합니다
이메일 자동 발송: Outlook과 연동하여 통계 결과를 자동으로 이메일로 발송하는 기능을 구현할 수 있습니다
고급 필터링: 금액 범위, 판매량 상위 N개 등 더 복잡한 조건을 추가할 수 있습니다
월별/분기별 집계: 날짜를 기준으로 월별, 분기별 통계를 자동으로 생성하는 기능도 유용합니다

마무리

이번 글에서 소개한 통합 검색 시스템은 여러 시트에 분산된 데이터를 효율적으로 관리하고 분석할 수 있는 강력한 도구입니다. 특히 VBA에서 자주 발생하는 런타임 오류 13번 문제를 해결한 안정적인 코드이므로, 실무에서 바로 활용할 수 있습니다. Dictionary 객체와 성능 최적화 기법을 이해하면 다양한 데이터 처리 작업에 응용할 수 있습니다. 여러분의 업무 환경에 맞게 수정하여 사용해보시기 바랍니다.

대용량 데이터 N개 파일로 분할 하기.xlsm

엑셀 VBA로 대용량 데이터 5만 행씩 자동 분할하는 방법

노만e — Wed, 12 Nov 2025 21:58:23 +0900

엑셀 50만 행 이상 데이터, 파일 분할로 해결하세요

엑셀에서 50만 행이 넘는 대용량 데이터를 다루다 보면 파일이 느려지거나 작업이 어려워지는 경우가 많습니다. 이럴 때 데이터를 여러 파일로 분할하면 작업 효율성이 크게 향상됩니다. 오늘은 VBA 매크로를 활용하여 대용량 엑셀 데이터를 10만 행씩 자동으로 분할 저장하는 방법을 자세히 알려드리겠습니다.

왜 엑셀 데이터를 분할해야 할까요?

대용량 엑셀 파일은 여러 가지 문제를 일으킵니다. 파일을 열고 저장하는 데 시간이 오래 걸리며, 수식 계산이나 필터링 작업 시 프로그램이 멈추거나 느려질 수 있습니다. 특히 50만 행이 넘어가면 엑셀의 성능이 급격히 저하되는 것을 경험하게 됩니다.

데이터를 적절한 크기로 분할하면 각 파일의 용량이 줄어들어 작업 속도가 빨라지고, 파일 관리도 훨씬 수월해집니다. 또한 특정 기간이나 범위의 데이터만 필요할 때 해당 파일만 열면 되므로 효율적입니다.

엑셀 VBA 데이터 분할 코드 전체

아래는 엑셀 데이터를 10만 행씩 자동으로 분할하여 저장하는 완전한 VBA 코드입니다.

Sub SplitDataIntoFiles()
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim lastRow As Long
    Dim rowsPerFile As Long
    Dim startRow As Long
    Dim endRow As Long
    Dim fileCount As Integer
    Dim savePath As String
    Dim originalFileName As String
    Dim headerRow As Range

    ' 화면 업데이트 중지 (속도 향상)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' 원본 시트 설정
    Set wsSource = ActiveSheet

    ' 파일당 행 수 설정
    rowsPerFile = InputBox("파일당 행 수를 입력해 주세요?", Default:=100000)

    ' 마지막 행 찾기
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

    ' 헤더 행 저장 (1행이 헤더라고 가정)
    Set headerRow = wsSource.Rows(1)

    ' 저장 경로 설정 (원본 파일과 같은 폴더)
    savePath = ThisWorkbook.Path & "\"
    originalFileName = Replace(ThisWorkbook.Name, ".xlsm", "")
    originalFileName = Replace(originalFileName, ".xlsx", "")

    ' 데이터 행 수 확인
    If lastRow <= 1 Then
        MsgBox "데이터가 없습니다.", vbExclamation
        GoTo CleanUp
    End If

    MsgBox "총 " & (lastRow - 1) & "개의 데이터 행을 분할합니다." & vbCrLf & _
           "예상 파일 수: " & Application.WorksheetFunction.RoundUp((lastRow - 1) / rowsPerFile, 0), vbInformation

    fileCount = 1
    startRow = 2 ' 데이터 시작 행 (헤더 다음)

    ' 데이터 분할 및 저장
    Do While startRow <= lastRow
        ' 끝 행 계산
        endRow = Application.Min(startRow + rowsPerFile - 1, lastRow)

        ' 새 통합 문서 생성
        Set wbNew = Workbooks.Add

        ' 헤더 복사
        headerRow.Copy Destination:=wbNew.Sheets(1).Rows(1)

        ' 데이터 복사
        wsSource.Rows(startRow & ":" & endRow).Copy _
            Destination:=wbNew.Sheets(1).Rows(2)

        ' 열 너비 자동 조정
        wbNew.Sheets(1).Columns.AutoFit

        ' 파일 저장
        Dim newFileName As String
        newFileName = savePath & originalFileName & "_Part" & fileCount & ".xlsx"

        ' 기존 파일이 있으면 삭제
        On Error Resume Next
        Kill newFileName
        On Error GoTo 0

        ' 저장
        wbNew.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook
        wbNew.Close SaveChanges:=False

        ' 진행 상황 표시
        Application.StatusBar = "처리 중: " & fileCount & "번째 파일 생성 완료 (" & _
                               startRow - 1 & " ~ " & endRow - 1 & " 행)"

        ' 다음 범위로 이동
        startRow = endRow + 1
        fileCount = fileCount + 1
    Loop

    MsgBox "완료! 총 " & (fileCount - 1) & "개의 파일이 생성되었습니다." & vbCrLf & _
           "저장 위치: " & savePath, vbInformation

CleanUp:
    ' 설정 복원
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    Set wsSource = Nothing
    Set wbNew = Nothing
    Set headerRow = Nothing
End Sub

엑셀 VBA 매크로 사용 방법 단계별 가이드

1단계: VBA 편집기 열기

엑셀을 실행한 후 키보드에서 Alt + F11 키를 동시에 누르면 VBA 편집기 창이 열립니다. 이 창에서 매크로 코드를 작성하고 관리할 수 있습니다.

2단계: 새 모듈 삽입하기

VBA 편집기 상단 메뉴에서 '삽입(Insert)' > '모듈(Module)'을 클릭합니다. 새로운 빈 모듈 창이 나타나면 여기에 코드를 입력할 준비가 완료된 것입니다.

3단계: VBA 코드 붙여넣기

위에 제공된 전체 코드를 복사하여 모듈 창에 붙여넣습니다. 코드가 올바르게 붙여넣어졌는지 확인하세요.

4단계: 매크로 실행하기

분할하려는 데이터가 있는 시트를 활성화한 후, Alt + F8 키를 누릅니다. 매크로 목록에서 'SplitDataIntoFiles'를 선택하고 실행 버튼을 클릭하면 자동으로 데이터 분할이 시작됩니다.

VBA 코드의 핵심 기능 설명

자동 헤더 복사 기능

이 매크로는 첫 번째 행을 헤더로 인식하여 모든 분할 파일에 자동으로 포함시킵니다. 따라서 각 파일을 열었을 때 어떤 데이터인지 바로 확인할 수 있어 편리합니다.

진행 상황 실시간 표시

작업이 진행되는 동안 엑셀 하단 상태 표시줄에 현재 몇 번째 파일을 생성 중인지, 어느 행까지 처리되었는지 실시간으로 표시됩니다. 대용량 데이터 처리 시 얼마나 남았는지 확인할 수 있어 유용합니다.

성능 최적화 설정

코드 시작 부분에서 화면 업데이트와 자동 계산을 일시적으로 중지하여 처리 속도를 대폭 향상시킵니다. 작업이 완료되면 자동으로 원래 설정으로 복원되므로 안심하고 사용할 수 있습니다.

자동 파일명 생성

원본 파일명에 "_Part1", "_Part2" 형식으로 번호가 자동으로 붙어 저장됩니다. 파일명만 보고도 순서를 쉽게 파악할 수 있습니다.

엑셀 데이터 분할 매크로 커스터마이징 방법

분할 행 수 변경하기

10만 행이 아닌 다른 행 수로 분할하고 싶다면 다음 부분을 수정하세요:

rowsPerFile = 100000  ' 원하는 행 수로 변경 (예: 50000, 200000 등)

예를 들어 5만 행씩 분할하려면 50000으로, 20만 행씩 분할하려면 200000으로 변경하면 됩니다.

저장 경로 지정하기

원본 파일이 있는 폴더가 아닌 다른 위치에 저장하고 싶다면 다음과 같이 수정합니다:

savePath = "C:\내문서\엑셀분할\"  ' 원하는 경로로 변경

경로 끝에 반드시 백슬래시()를 포함해야 하며, 해당 폴더가 미리 생성되어 있어야 합니다.

파일 형식 변경하기

xlsx 대신 다른 형식으로 저장하려면 SaveAs 부분을 수정할 수 있습니다. xlOpenXMLWorkbook 대신 xlExcel8(xls 형식) 또는 xlCSV(CSV 형식) 등으로 변경 가능합니다.

대용량 엑셀 데이터 처리 시 주의사항

메모리 확인하기

50만 행 이상의 데이터를 처리할 때는 충분한 메모리가 필요합니다. 작업 전 다른 프로그램을 종료하여 메모리를 확보하는 것이 좋습니다.

원본 파일 백업하기

매크로 실행 전 반드시 원본 파일을 백업해두세요. 예상치 못한 오류가 발생할 경우를 대비하여 안전하게 작업할 수 있습니다.

첫 행이 헤더인지 확인하기

이 코드는 첫 번째 행을 헤더로 가정합니다. 만약 데이터 구조가 다르다면 코드의 headerRow 부분을 수정해야 합니다.

충분한 저장 공간 확보하기

분할된 파일들이 저장될 충분한 디스크 공간이 있는지 확인하세요. 50만 행을 5개 파일로 나누면 원본보다 더 많은 공간이 필요할 수 있습니다.

엑셀 VBA 데이터 분할 매크로의 장점

작업 시간 대폭 단축

수동으로 데이터를 복사하고 붙여넣는 작업은 시간이 오래 걸리고 실수하기 쉽습니다. 이 매크로를 사용하면 클릭 한 번으로 모든 작업이 자동으로 완료됩니다.

정확성 보장

사람이 직접 작업하면 행을 빠뜨리거나 중복으로 복사하는 실수가 발생할 수 있습니다. 매크로는 정확하게 지정된 행 수만큼만 분할하므로 데이터 무결성이 보장됩니다.

반복 작업에 최적화

정기적으로 대용량 데이터를 받아서 분할해야 하는 업무라면 매크로를 한 번 설정해두고 계속 재사용할 수 있어 매우 효율적입니다.

엑셀 데이터 분할 후 활용 팁

파일명 규칙 만들기

분할된 파일들을 관리하기 쉽도록 날짜나 버전을 파일명에 포함시키는 것이 좋습니다. 코드를 수정하여 자동으로 날짜가 들어가도록 설정할 수 있습니다.

데이터 검증하기

분할 작업이 완료되면 첫 번째와 마지막 파일을 열어 데이터가 올바르게 나뉘었는지 확인하세요. 특히 행 수와 헤더가 제대로 포함되었는지 점검하는 것이 중요합니다.

압축하여 보관하기

분할된 파일들을 장기 보관할 경우 zip 파일로 압축하면 저장 공간을 절약할 수 있습니다.

마치며

엑셀에서 50만 행 이상의 대용량 데이터를 다루는 것은 더 이상 어려운 일이 아닙니다. 오늘 소개한 VBA 매크로를 활용하면 데이터를 10만 행씩 자동으로 분할하여 작업 효율성을 크게 높일 수 있습니다. 코드를 복사하여 바로 사용할 수 있으며, 필요에 따라 행 수나 저장 경로를 쉽게 변경할 수 있습니다.

대용량 데이터 처리로 고민하고 계셨다면 이 매크로를 활용해보세요. 작업 시간을 대폭 단축하고 정확한 데이터 관리가 가능해질 것입니다.

8.10MB

Excel VBA로 인사기록 팀별 별도 파일로 저장하기

노만e — Tue, 11 Nov 2025 22:23:04 +0900

개요

Excel에서 대량의 인사기록 데이터를 팀별로 분류하여 개별 파일로 저장해야 하는 경우가 많습니다. 수십 개의 팀이 있고 각 팀마다 수백 건의 데이터가 있다면, 수작업으로 처리하는 것은 매우 비효율적입니다. 이 글에서는 VBA 매크로를 활용하여 클릭 한 번으로 팀별 데이터를 자동 분류하고 개별 파일로 저장하는 방법을 소개합니다.

이 글에서 배울 수 있는 것:

Excel VBA 매크로를 이용한 데이터 자동 분류
CurrentRegion을 활용한 데이터 범위 자동 인식
배열을 이용한 대용량 데이터 처리 속도 최적화
팀별 파일 자동 생성 및 저장
병합된 셀 처리 방법

키워드: Excel VBA, 데이터 자동 분류, 팀별 파일 저장, CurrentRegion, Excel 매크로, 인사기록 관리, 대용량 데이터 처리

문제 상황

다음과 같은 상황에서 이 매크로가 유용합니다:

예시 데이터 구조:

문제점:

10개 이상의 팀이 있고 각 팀마다 수십~수백 건의 데이터가 있음
각 팀별로 별도의 Excel 파일로 저장해야 함
수작업으로 필터링하고 복사-붙여넣기하면 시간이 오래 걸림
실수로 데이터를 누락하거나 잘못 분류할 위험이 있음
병합된 셀이 있는 경우 처리가 복잡함

해결 방법

이 VBA 매크로는 다음과 같이 작동합니다:

팀명이 있는 열의 셀을 클릭하여 선택
CurrentRegion을 이용해 데이터 범위를 자동 인식
중복을 제거하여 팀 목록을 자동 생성
각 팀별로 데이터를 필터링
워크북 이름으로 폴더를 자동 생성
각 팀별로 개별 Excel 파일을 자동 저장

소요 시간: 1,000건의 데이터를 10개 팀으로 분류하는데 약 5~10초 소요 (수작업 대비 90% 이상 시간 절약)

VBA 코드 전체

버전 1: 속도 최적화 버전 (값만 복사)

Sub 팀별파일자동저장_CurrentRegion()
    Dim ws As Worksheet
    Dim newWB As Workbook
    Dim dataRange As Range
    Dim teamColumn As Long
    Dim selectedTeam As String
    Dim fileName As String
    Dim folderPath As String
    Dim i As Long
    Dim selectedRange As Range
    Dim teamList As Object
    Dim teamKey As Variant
    Dim savedCount As Long
    Dim fso As Object
    Dim startTime As Double
    Dim dataArray As Variant
    Dim outputArray() As Variant
    Dim outputRow As Long
    Dim col As Long
    Dim firstRow As Long
    Dim lastRow As Long
    Dim firstCol As Long
    Dim lastCol As Long
    Dim headerRows As Long

    startTime = Timer

    ' 현재 활성 시트 설정
    Set ws = ActiveSheet

    ' 사용자에게 팀명이 있는 열의 셀 선택 요청
    On Error Resume Next
    Set selectedRange = Application.InputBox( _
        Prompt:="팀명이 입력된 열의 아무 셀이나 선택하세요." & vbCrLf & _
               "(해당 셀의 데이터 영역이 자동으로 인식됩니다)", _
        Title:="팀명 열 선택", _
        Type:=8)
    On Error GoTo 0

    ' 취소 버튼 클릭 시 종료
    If selectedRange Is Nothing Then
        MsgBox "취소되었습니다."
        Exit Sub
    End If

    ' 병합된 셀인 경우 첫 번째 셀 선택
    If selectedRange.MergeCells Then
        Set selectedRange = selectedRange.MergeArea.Cells(1, 1)
    End If

    ' CurrentRegion으로 데이터 범위 자동 인식
    Set dataRange = selectedRange.CurrentRegion

    ' 데이터 범위 정보
    firstRow = dataRange.Row
    lastRow = dataRange.Row + dataRange.Rows.Count - 1
    firstCol = dataRange.Column
    lastCol = dataRange.Column + dataRange.Columns.Count - 1

    ' 선택한 셀의 열 번호 (데이터 범위 내에서의 상대 위치)
    teamColumn = selectedRange.Column - firstCol + 1

    ' 헤더 행 수 확인 (병합된 셀이나 제목 행 감지)
    headerRows = 1
    For i = firstRow To firstRow + 5
        If i > lastRow Then Exit For

        ' 병합된 셀이 많거나 비어있는 셀이 많으면 헤더로 간주
        Dim mergedCount As Long
        Dim emptyCount As Long
        mergedCount = 0
        emptyCount = 0

        For col = firstCol To lastCol
            If ws.Cells(i, col).MergeCells Then
                mergedCount = mergedCount + 1
            End If
            If IsEmpty(ws.Cells(i, col).Value) Then
                emptyCount = emptyCount + 1
            End If
        Next col

        ' 다음 행이 실제 데이터 행인지 확인
        If i < lastRow Then
            If mergedCount < 2 And emptyCount < (lastCol - firstCol + 1) / 2 Then
                headerRows = i - firstRow + 1
                Exit For
            End If
        End If
    Next i

    ' 데이터 시작 행
    Dim dataStartRow As Long
    dataStartRow = firstRow + headerRows

    ' 데이터가 없는 경우
    If dataStartRow > lastRow Then
        MsgBox "데이터가 없습니다.", vbExclamation
        Exit Sub
    End If

    ' 화면 업데이트 중지
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' 전체 데이터를 배열로 읽기
    dataArray = dataRange.Value2

    ' 중복 제거된 팀 목록 생성
    Set teamList = CreateObject("Scripting.Dictionary")

    For i = headerRows + 1 To UBound(dataArray, 1)
        Dim currentTeam As String
        currentTeam = Trim(CStr(dataArray(i, teamColumn)))

        If currentTeam <> "" Then
            If Not teamList.exists(currentTeam) Then
                teamList(currentTeam) = 1
            End If
        End If
    Next i

    ' 팀이 없는 경우
    If teamList.Count = 0 Then
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        MsgBox "팀 데이터가 없습니다.", vbExclamation
        Exit Sub
    End If

    ' 파일 시스템 객체 생성
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' 폴더 경로 생성
    Dim workbookName As String
    workbookName = fso.GetBaseName(ThisWorkbook.Name)
    folderPath = ThisWorkbook.Path & "\" & workbookName

    ' 폴더가 없으면 생성
    If Not fso.FolderExists(folderPath) Then
        fso.CreateFolder folderPath
    End If

    savedCount = 0
    Dim totalCols As Long
    totalCols = UBound(dataArray, 2)

    ' 각 팀별로 파일 생성
    For Each teamKey In teamList.Keys
        selectedTeam = CStr(teamKey)

        ' 출력 배열 크기 설정
        ReDim outputArray(1 To UBound(dataArray, 1), 1 To totalCols)

        ' 헤더 복사
        For i = 1 To headerRows
            For col = 1 To totalCols
                outputArray(i, col) = dataArray(i, col)
            Next col
        Next i

        ' 해당 팀 데이터만 배열에 복사
        outputRow = headerRows + 1
        For i = headerRows + 1 To UBound(dataArray, 1)
            If Trim(CStr(dataArray(i, teamColumn))) = selectedTeam Then
                For col = 1 To totalCols
                    outputArray(outputRow, col) = dataArray(i, col)
                Next col
                outputRow = outputRow + 1
            End If
        Next i

        ' 데이터가 있는 경우만 저장
        If outputRow > headerRows + 1 Then
            ' 새 워크북 생성
            Set newWB = Workbooks.Add

            ' 배열 데이터를 한번에 붙여넣기
            newWB.Sheets(1).Range(newWB.Sheets(1).Cells(1, 1), _
                                  newWB.Sheets(1).Cells(outputRow - 1, totalCols)).Value2 = outputArray

            ' 열 너비 자동 조정
            newWB.Sheets(1).Columns.AutoFit

            ' 시트 이름 변경
            On Error Resume Next
            newWB.Sheets(1).Name = Left(selectedTeam, 31)
            On Error GoTo 0

            ' 파일명에 사용할 수 없는 문자 제거
            Dim cleanTeamName As String
            cleanTeamName = selectedTeam
            cleanTeamName = Replace(cleanTeamName, "/", "_")
            cleanTeamName = Replace(cleanTeamName, "\", "_")
            cleanTeamName = Replace(cleanTeamName, ":", "_")
            cleanTeamName = Replace(cleanTeamName, "*", "_")
            cleanTeamName = Replace(cleanTeamName, "?", "_")
            cleanTeamName = Replace(cleanTeamName, """", "_")
            cleanTeamName = Replace(cleanTeamName, "<", "_")
            cleanTeamName = Replace(cleanTeamName, ">", "_")
            cleanTeamName = Replace(cleanTeamName, "|", "_")

            ' 파일명 생성
            fileName = folderPath & "\" & cleanTeamName & ".xlsx"

            ' 파일 저장
            On Error Resume Next
            newWB.SaveAs fileName:=fileName, FileFormat:=xlOpenXMLWorkbook

            If Err.Number = 0 Then
                savedCount = savedCount + 1
            End If
            On Error GoTo 0

            newWB.Close SaveChanges:=False
        End If
    Next teamKey

    ' 설정 복원
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True

    ' 완료 메시지
    Dim elapsedTime As Double
    elapsedTime = Timer - startTime

    If savedCount > 0 Then
        MsgBox "작업 완료!" & vbCrLf & vbCrLf & _
               "인식된 데이터 범위: " & dataRange.Address & vbCrLf & _
               "저장된 팀 수: " & savedCount & "개" & vbCrLf & _
               "소요 시간: " & Format(elapsedTime, "0.00") & "초" & vbCrLf & _
               "저장 위치: " & folderPath, vbInformation, "팀별 파일 저장 완료"

        ' 폴더 열기
        Shell "explorer.exe " & folderPath, vbNormalFocus
    Else
        MsgBox "저장된 파일이 없습니다.", vbExclamation
    End If

End Sub

코드 설치 및 실행 방법

1단계: VBA 편집기 열기

Excel 파일을 열고 다음 중 하나의 방법으로 VBA 편집기를 엽니다:

Alt + F11 키를 누릅니다
또는 개발 도구 탭 > Visual Basic 클릭

참고: 개발 도구 탭이 보이지 않는 경우

파일 > 옵션 > 리본 사용자 지정

오른쪽에서 "개발 도구" 체크박스 선택

확인 클릭

2단계: 새 모듈 만들기

VBA 편집기 좌측의 프로젝트 탐색기에서 현재 워크북을 찾습니다
삽입(Insert) > 모듈(Module) 클릭
새로운 빈 모듈 창이 열립니다

3단계: 코드 붙여넣기

위의 VBA 코드 전체를 복사합니다
모듈 창에 붙여넣기 합니다
Ctrl + S로 저장합니다

중요: 파일을 .xlsm 형식(매크로 포함 통합 문서)으로 저장해야 합니다.

4단계: 매크로 실행

Excel로 돌아가기 (Alt + F11 또는 VBA 편집기 닫기)
Alt + F8 키를 눌러 매크로 목록 열기
원하는 매크로 선택:
- 팀별파일자동저장_CurrentRegion (속도 우선)
- 팀별파일자동저장_CurrentRegion_서식유지 (서식 유지)
실행 버튼 클릭
팀명이 있는 열의 아무 셀이나 클릭하여 선택
자동으로 처리됩니다!

코드 상세 설명

CurrentRegion을 이용한 데이터 범위 자동 인식

Set dataRange = selectedRange.CurrentRegion

CurrentRegion은 선택한 셀을 포함하는 연속된 데이터 영역을 자동으로 찾아주는 Excel의 강력한 기능입니다. 빈 행이나 빈 열로 구분된 데이터 블록을 자동으로 인식하므로, 사용자가 데이터의 시작과 끝을 지정할 필요가 없습니다.

장점:

데이터가 A1부터 시작하지 않아도 자동 인식
데이터 크기가 변경되어도 자동 대응
병합된 셀이 있어도 정확하게 인식

배열을 이용한 고속 데이터 처리

dataArray = dataRange.Value2

Excel 셀을 하나씩 읽고 쓰는 것은 매우 느립니다. 이 코드는 전체 데이터를 한 번에 배열로 읽어들여 메모리에서 처리하므로 수백 배 빠른 속도를 구현합니다.

속도 비교:

셀 단위 처리: 1,000건 약 30~60초
배열 처리: 1,000건 약 3~5초

Dictionary를 이용한 중복 제거

Set teamList = CreateObject("Scripting.Dictionary")

Dictionary 객체는 중복을 자동으로 제거하면서 팀 목록을 생성합니다. 배열이나 컬렉션보다 훨씬 빠르고 효율적입니다.

병합된 셀 처리

If ws.Cells(i, teamColumn).MergeCells Then
    cellValue = ws.Cells(i, teamColumn).MergeArea.Cells(1, 1).Value
Else
    cellValue = ws.Cells(i, teamColumn).Value
End If

병합된 셀의 경우 MergeArea를 통해 병합 영역의 첫 번째 셀 값을 가져옵니다.

파일명 특수문자 처리

cleanTeamName = Replace(cleanTeamName, "/", "_")
cleanTeamName = Replace(cleanTeamName, "\", "_")
' ... 기타 특수문자 처리

Windows 파일명에 사용할 수 없는 문자(/ \ : * ? " < > |)를 자동으로 언더스코어(_)로 변경합니다.

화면 업데이트 비활성화

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False

이 설정들은 처리 속도를 극대화합니다:

ScreenUpdating: 화면 깜빡임 방지
Calculation: 수식 자동 계산 일시 중지
EnableEvents: 이벤트 처리 중지
DisplayAlerts: 경고창 표시 안 함

주요 기능

1. 자동 데이터 범위 인식

클릭한 셀을 기준으로 CurrentRegion을 이용해 연속된 데이터 영역을 자동으로 찾습니다.

2. 헤더 자동 감지

병합된 셀이나 빈 셀의 패턴을 분석하여 헤더 행 수를 자동으로 판단합니다.

3. 중복 제거

Dictionary 객체를 사용하여 팀명의 중복을 자동으로 제거합니다.

4. 자동 폴더 생성

워크북 이름으로 폴더를 자동 생성하고, 그 안에 팀별 파일을 저장합니다.

폴더 구조 예시:

원본파일.xlsm
└── 원본파일/
    ├── 기술팀.xlsx
    ├── 경비1팀.xlsx
    ├── 운영팀.xlsx
    └── ...

5. 자동 파일명 생성

각 팀명을 파일명으로 사용하며, 특수문자는 자동으로 처리합니다.

6. 처리 시간 표시

작업 완료 후 소요 시간을 표시하여 성능을 확인할 수 있습니다.

7. 폴더 자동 열기

작업 완료 후 생성된 폴더가 자동으로 열려 결과를 바로 확인할 수 있습니다.

성능 최적화 포인트

1. 배열 사용

셀을 직접 읽고 쓰는 대신 배열을 사용하여 메모리에서 처리합니다. 이는 디스크 I/O를 최소화하여 속도를 대폭 향상시킵니다.

2. Value2 속성 사용

dataArray = dataRange.Value2

Value2는 Value보다 빠릅니다. Value는 날짜나 통화 형식을 변환하지만, Value2는 원시 값을 그대로 가져옵니다.

3. 화면 업데이트 비활성화

화면 갱신을 중지하여 불필요한 리소스 사용을 막습니다.

4. 한 번에 붙여넣기

newWB.Sheets(1).Range(...).Value2 = outputArray

셀을 하나씩 쓰는 대신 배열 전체를 한 번에 붙여넣습니다.

5. Dictionary 사용

배열이나 컬렉션 대신 Dictionary를 사용하여 중복 확인 속도를 향상시킵니다.

성능 비교 (1,000건 데이터, 10개 팀 기준):

최적화 전: 약 45~60초
최적화 후: 약 3~7초
성능 향상: 약 85~90%

문제 해결

Q1: "매크로를 찾을 수 없습니다" 오류

해결 방법:

파일을 .xlsm 형식으로 저장했는지 확인
VBA 편집기에서 코드가 제대로 붙여넣어졌는지 확인
모듈 이름이 "Module1" 등으로 제대로 생성되었는지 확인

Q2: "매크로가 비활성화되었습니다" 경고

해결 방법:

파일을 열 때 "콘텐츠 사용" 버튼 클릭
또는 파일 > 옵션 > 보안 센터 > 보안 센터 설정 > 매크로 설정에서 "모든 매크로 포함" 선택 (보안 주의)

Q3: 데이터 범위가 잘못 인식됩니다

원인: 데이터 중간에 빈 행이나 빈 열이 있는 경우

해결 방법:

데이터 중간의 빈 행/열 제거
또는 데이터를 표(Table)로 변환 (Ctrl + T)

Q4: 특정 팀의 파일이 생성되지 않습니다

원인: 해당 팀의 데이터가 없거나 팀명이 공백인 경우

해결 방법:

팀명 열에 공백이나 특수문자가 없는지 확인
필터를 사용하여 해당 팀 데이터가 실제로 존재하는지 확인

Q5: "파일 저장 중 오류" 메시지

원인:

동일한 이름의 파일이 이미 열려 있음
폴더에 쓰기 권한이 없음
디스크 공간 부족

해결 방법:

동일한 이름의 파일이 열려 있다면 닫기
관리자 권한으로 Excel 실행
디스크 공간 확인

Q6: 처리 속도가 너무 느립니다

원인: 데이터가 매우 많거나 서식이 복잡한 경우

해결 방법:

"속도 최적화 버전" 사용 (서식 없이 값만 복사)
불필요한 서식 제거
조건부 서식이나 수식이 많다면 값으로 변환 후 실행

Q7: 병합된 셀이 제대로 처리되지 않습니다

해결 방법: "서식 유지 버전" 매크로를 사용하세요. 이 버전은 병합된 셀을 포함한 모든 서식을 유지합니다.

마치며

이 VBA 매크로를 사용하면 수작업으로 몇 시간 걸리던 작업을 단 몇 초 만에 완료할 수 있습니다. 인사기록뿐만 아니라 다양한 데이터 분류 작업에 활용할 수 있습니다.

활용 가능한 분야:

부서별/팀별 인사 데이터 관리
지역별 매출 데이터 분리
제품별 재고 현황 분리
고객사별 주문 내역 분리
프로젝트별 작업 내역 분리

추가 커스터마이징 팁:

파일명에 날짜 추가: fileName = folderPath & "\" & cleanTeamName & "_" & Format(Date, "yyyymmdd") & ".xlsx"
특정 열만 선택하여 저장
조건부 필터링 추가 (예: 특정 기간의 데이터만)
PDF로 저장하는 기능 추가

관련 글:

Excel VBA 기초 문법 완벽 가이드
Excel 데이터 자동화 실전 예제
VBA로 반복 작업 자동화하기

이 코드가 도움이 되셨다면 댓글로 피드백을 남겨주세요. 궁금한 점이나 개선 사항이 있다면 언제든지 문의해 주시기 바랍니다!

인사평가 집계표.xlsm

엑셀VBA로 대량 이메일 보내기 자동화 매크로.xlsm

엑셀 VBA로 자동 이메일 발송하기 - 완벽 가이드

노만e — Sun, 2 Nov 2025 23:50:19 +0900

개요

엑셀에서 VBA 매크로를 사용하여 Outlook을 통해 대량의 이메일을 자동으로 발송하는 방법을 소개합니다. 이 코드는 실무에서 바로 활용 가능하며, 발송 결과를 자동으로 기록하고 오류 처리까지 완벽하게 구현되어 있습니다.

주요 기능

✅ 대량 이메일 자동 발송: 여러 건의 메일을 한 번에 발송
✅ 첨부파일 지원: 각 메일마다 개별 첨부파일 추가 가능
✅ 발송 결과 자동 기록: 성공/실패 여부와 시간을 자동으로 엑셀에 기록
✅ 에러 처리: 발송 실패 시에도 다음 메일 계속 발송
✅ 진행 상황 표시: 상태 표시줄에 실시간 진행률 표시
✅ CC 기능: 참조 수신자 추가 가능

엑셀 시트 구조

Mail_Send라는 이름의 시트를 생성하고 다음과 같이 구성하세요:

A열 (To)B열 (CC)C열 (Subject)D열 (Body)E열 (Status)F열 (Attachment)

수신자 이메일

참조 이메일

제목

본문

발송상태

첨부파일 경로

예시:

A2: example@company.com
B2: cc@company.com (선택사항)
C2: 11월 업무 보고서 제출 안내
D2: 안녕하세요. 11월 업무 보고서를 제출해 주시기 바랍니다.
E2: (비워둠 - 자동으로 채워짐)
F2: C:\Documents\report.pdf (선택사항)

VBA 코드

Sub SendEmail_Complete()
    On Error GoTo ErrorHandler

    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim SuccessCount As Long
    Dim FailCount As Long

    ' 초기화
    SuccessCount = 0
    FailCount = 0

    Set ws = ActiveWorkbook.Sheets("Mail_Send")
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' 데이터가 없는 경우 처리
    If LastRow < 2 Then
        MsgBox "발송할 데이터가 없습니다.", vbExclamation
        Exit Sub
    End If

    ' 사용자 확인
    If MsgBox("총 " & LastRow - 1 & "건의 메일을 발송하시겠습니까?", vbYesNo + vbQuestion, "메일 발송 확인") = vbNo Then
        Exit Sub
    End If

    Set OutlookApp = CreateObject("Outlook.Application")

    ' 진행 상황 표시를 위한 상태 표시줄 사용
    Application.ScreenUpdating = False

    For i = 2 To LastRow
        Application.StatusBar = "메일 발송 중... (" & i - 1 & "/" & LastRow - 1 & ")"

        On Error Resume Next

        If ws.Cells(i, 1).Value <> "" Then
            Set OutlookMail = OutlookApp.CreateItem(0)

            With OutlookMail
                .To = ws.Cells(i, 1).Value
                .CC = ws.Cells(i, 2).Value ' CC (선택사항)
                .Subject = ws.Cells(i, 3).Value
                .Body = ws.Cells(i, 4).Value

                ' 첨부파일이 있는 경우
                If ws.Cells(i, 6).Value <> "" Then
                    If Dir(ws.Cells(i, 6).Value) <> "" Then
                        .Attachments.Add ws.Cells(i, 6).Value
                    End If
                End If

                .Send
            End With

            If Err.Number = 0 Then
                ws.Cells(i, 5).Value = "발송완료 - " & Format(Now, "yyyy-mm-dd hh:mm:ss")
                ws.Cells(i, 5).Interior.Color = RGB(144, 238, 144)
                SuccessCount = SuccessCount + 1
            Else
                ws.Cells(i, 5).Value = "발송실패 - " & Err.Description
                ws.Cells(i, 5).Interior.Color = RGB(255, 182, 193)
                FailCount = FailCount + 1
                Err.Clear
            End If

            Set OutlookMail = Nothing
        End If

        On Error GoTo ErrorHandler

        ' 서버 부하 방지를 위한 짧은 대기 시간
        Application.Wait (Now + TimeValue("0:00:01"))
    Next i

    ' 정리
    Application.ScreenUpdating = True
    Application.StatusBar = False

    Set OutlookApp = Nothing
    Set ws = Nothing

    ' 결과 메시지
    MsgBox "메일 발송이 완료되었습니다!" & vbCrLf & vbCrLf & _
           "성공: " & SuccessCount & "건" & vbCrLf & _
           "실패: " & FailCount & "건", vbInformation, "발송 완료"

    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "오류가 발생했습니다: " & Err.Description, vbCritical

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Set ws = Nothing
End Sub

사용 방법

1. VBA 편집기 열기

Alt + F11을 눌러 VBA 편집기를 엽니다.

2. 모듈 추가

메뉴에서 삽입 > 모듈을 선택합니다.

3. 코드 붙여넣기

위의 코드를 복사하여 모듈에 붙여넣습니다.

4. 엑셀 데이터 준비

Mail_Send 시트에 발송할 이메일 정보를 입력합니다.

5. 매크로 실행

Alt + F8을 누르고 SendEmail_Complete를 선택하여 실행합니다.

코드 상세 설명

발송 전 확인 기능

vba

If MsgBox("총 " & LastRow - 1 & "건의 메일을 발송하시겠습니까?", vbYesNo + vbQuestion) = vbNo Then
    Exit Sub
End If

실수로 대량 발송하는 것을 방지하기 위한 확인 메시지를 표시합니다.

진행 상황 표시

vba

Application.StatusBar = "메일 발송 중... (" & i - 1 & "/" & LastRow - 1 & ")"

엑셀 하단 상태 표시줄에 현재 진행률을 실시간으로 표시합니다.

발송 결과 기록

성공 시:

E열에 "발송완료" + 시간 기록
셀 배경색을 연두색으로 표시

실패 시:

E열에 "발송실패" + 오류 메시지 기록
셀 배경색을 분홍색으로 표시

서버 부하 방지

vba

Application.Wait (Now + TimeValue("0:00:01"))

각 메일 발송 후 1초 대기하여 서버 부하를 방지합니다.

주의사항

Outlook 설치 필수: 이 코드는 Outlook을 통해 메일을 발송하므로 Outlook이 설치되어 있어야 합니다.
메일 서버 설정: Outlook이 메일 계정과 연결되어 있어야 합니다.
첨부파일 경로: 첨부파일은 절대 경로로 입력해야 하며, 파일이 실제로 존재해야 합니다.
매크로 보안 설정: 매크로가 실행되지 않으면 파일 > 옵션 > 보안 센터 > 매크로 설정에서 허용해야 합니다.
대량 발송 시: 일반적으로 하루 발송 제한이 있을 수 있으므로 대량 발송 시 주의하세요.

커스터마이징 팁

HTML 형식 본문 사용

.Body 대신 .HTMLBody를 사용하면 HTML 형식의 메일을 발송할 수 있습니다:

vba

.HTMLBody = ws.Cells(i, 4).Value

대기 시간 조정

서버 상황에 맞게 대기 시간을 조절할 수 있습니다:

vba

Application.Wait (Now + TimeValue("0:00:02")) ' 2초로 변경

시트 이름 변경

다른 시트 이름을 사용하려면 해당 부분을 수정하세요:

vba

Set ws = ActiveWorkbook.Sheets("원하는시트이름")

활용 사례

고객 대상 프로모션 메일 발송
월간 보고서 자동 배포
교육 자료 일괄 전송
업무 공지사항 전달
생일 축하 메시지 자동 발송

문제 해결

"Mail_Send 시트를 찾을 수 없습니다" 오류

엑셀 파일에 Mail_Send라는 정확한 이름의 시트가 있는지 확인하세요.

첨부파일이 첨부되지 않음

파일 경로가 정확한지 확인하세요.
역슬래시(\)를 사용해야 합니다.
파일이 실제로 존재하는지 확인하세요.

Outlook이 열리지 않음

Outlook이 설치되어 있는지 확인하세요.
Outlook을 한 번 수동으로 실행해보세요.

마치며

이 VBA 매크로를 사용하면 반복적인 이메일 발송 업무를 자동화하여 업무 효율을 크게 높일 수 있습니다. 코드를 자신의 환경에 맞게 수정하여 활용해보세요!

엑셀 VBA로 PDS 다이어리 자동 생성하기

노만e — Sun, 26 Oct 2025 22:38:18 +0900

PDS 다이어리란?

PDS(Plan-Do-See) 다이어리는 계획, 실행, 피드백의 과정을 체계적으로 기록하여 자기 계발을 돕는 다이어리입니다. 시판되는 제품을 구매하거나, 블로그나 커뮤니티에서 무료로 배포되는 양식(PDF, PPT, 엑셀 등)을 활용할 수 있습니다.

PDS 다이어리 양식의 핵심 요소

PLAN(계획): 하루 또는 한 주간의 목표와 세부 계획을 세우는 단계입니다.
- 핵심 목표: 그날 반드시 달성해야 할 중요한 일 1~3가지를 명확히 작성합니다.
- 시간 계획: 하루를 1시간 또는 10분 단위로 나눠 시간대별로 할 일을 구체적으로 기록합니다.
- 우선순위: 계획한 일에 우선순위를 부여하여 중요도에 따라 일을 처리할 수 있도록 합니다.
DO(실행): 계획한 내용을 실제로 실행하고 기록하는 단계입니다.
- 실행 확인: 계획한 시간대에 실제로 실행했는지 여부를 표시합니다.
- 시간 관리: 계획대로 진행되지 않은 시간을 시각적으로 확인하고 시간 낭비 요소를 파악합니다.
SEE(피드백): 실행 결과를 되돌아보며 개선점을 찾는 단계입니다.
- 회고(Review): 하루를 마무리하며 잘한 점, 아쉬운 점, 개선할 점 등을 기록합니다.
- 문제 분석: 계획대로 진행되지 않은 원인을 분석하고 다음 계획에 반영할 점을 찾습니다.

주요 기능

이 VBA 프로그램은 다음 기능을 제공합니다:

1. 자동 날짜 입력 시스템

YYYY-MM-DD 형식의 날짜 입력
자동 요일 계산 및 한글 표시
날짜 유효성 검증

2. 구조화된 레이아웃

WEEKLY 섹션: 주간 목표 및 계획
PLAN/DO 섹션: 시간대별(6시~24시) 계획 및 실행 기록
SEE 섹션: Keep-Problem-Try 회고

3. 자동 UI 요소

체크박스 자동 생성(F4~F22 범위)
인쇄 최적화 설정
가독성 높은 테두리 및 색상

코드 구조 분석

메인 실행 함수: CreatePDSDiary()

vba

Sub CreatePDSDiary()
    ' 1. 날짜 입력 받기
    ' 2. 유효성 검사
    ' 3. 시트 생성
    ' 4. 레이아웃 구성
End Sub

이 함수는 프로그램의 진입점으로, 사용자 입력부터 다이어리 생성까지 전체 프로세스를 관리합니다.

날짜 검증: IsValidDate()

vba

Function IsValidDate(dateStr As String) As Boolean
    ' YYYY-MM-DD 형식 확인
    ' 하이픈 위치 검증
    ' 실제 날짜 변환 가능 여부 확인
End Function

입력된 날짜가 올바른 형식인지 확인하고, 실제 존재하는 날짜인지 검증합니다.

한글 요일 변환: GetKoreanDayOfWeek()

vba

Function GetKoreanDayOfWeek(targetDate As Date) As String
    Dim days(1 To 7) As String
    days(1) = "일요일"
    ' ... 월~토요일
    dayNum = Weekday(targetDate)
    GetKoreanDayOfWeek = days(dayNum)
End Function

엑셀의 Weekday 함수를 활용하여 한글 요일을 반환합니다.

레이아웃 상세 구조

1. 페이지 설정 (SetupPageLayout)

열 너비:
- A열: 2 (여백)
- B~D열: 15 (WEEKLY 섹션)
- E열: 2 (여백)
- F~N열: 12 (메인 다이어리)
- J열: 6 (시간 표시)

행 높이: 21
화면 줌: 85%
폰트: 맑은 고딕 10pt

2. WEEKLY 섹션 (B1:D31)

주간 목표와 중요 업무를 기록하는 공간입니다. 병합된 셀로 구성되어 자유로운 텍스트 입력이 가능합니다.

3. MEMO 섹션 (F3:N22)

헤더 구조:

PLAN (F3:I3): 계획
TIME (J3): 시간
DO (K3:N3): 실행

시간 블록:

6시부터 24시까지 19개 시간대
각 시간대마다 체크박스 자동 생성
PLAN과 DO를 분리하여 계획 대비 실행률 시각화

4. SEE 섹션 (F24:N30)

KPT 회고 프레임워크:

Keep: 잘한 점, 계속 유지할 것
Problem: 문제점, 개선이 필요한 것
Try: 다음에 시도해볼 것

활용 팁

1. 색상 커스터마이징

vba

' 헤더 배경색 변경
.Range("F1:N2").Interior.Color = RGB(248, 248, 248)

' 다른 색상 예시
' 파스텔 블루: RGB(173, 216, 230)
' 파스텔 그린: RGB(198, 226, 198)
' 연한 노랑: RGB(255, 255, 204)

2. 시간 범위 조정

vba

' CreateMemoSection 함수 내부
For hour = 6 To 24  ' 시작 시간과 종료 시간 변경 가능

3. 인쇄 설정 최적화

vba

' printPreviewHorizontal 함수에서 여백 조정
.LeftMargin = Application.InchesToPoints(0.3)
.RightMargin = Application.InchesToPoints(0.5)

설치 및 사용 방법

1. VBA 편집기 열기

Alt + F11 키를 누르거나
개발 도구 탭 → Visual Basic 클릭

2. 모듈 삽입

삽입 → 모듈 선택
제공된 코드 전체 복사 후 붙여넣기

' ========================================
' PDS 다이어리 만들기
' ========================================

Option Explicit

' 전역 변수
Dim targetSheet As Worksheet

' 메인 실행 함수
Sub CreatePDSDiary()
    Dim inputDate As String
    Dim selectedDate As Date
    Dim dayOfWeek As String
    Dim ws As Worksheet
    Dim sheetName As String

    On Error Resume Next
    ' 날짜 입력 받기
    inputDate = InputBox("일일 일정표를 만들 날짜를 YYYY-MM-DD 형식으로 입력하세요", "일일 일정표", Format(Date, "yyyy-mm-dd"))

    ' 취소 버튼 클릭 시
    If inputDate = "" Then
        Exit Sub
    End If

    ' 날짜 유효성 검사
    If Not IsValidDate(inputDate) Then
        MsgBox "올바른 날짜 형식이 아닙니다. YYYY-MM-DD 형식으로 입력해주세요.", vbExclamation, "오류"
        Exit Sub
    End If

    ' 날짜 변환
    selectedDate = CDate(inputDate)
    dayOfWeek = GetKoreanDayOfWeek(selectedDate)
    sheetName = Format(selectedDate, "mmdd")

    ' 기존 시트 확인
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    On Error GoTo 0

    If Not ws Is Nothing Then
        ' 같은 날짜의 시트가 이미 존재함
        MsgBox "같은 날짜(" & Format(selectedDate, "mm/dd") & ")의 일정표가 이미 존재합니다.", vbInformation, "알림"
        Exit Sub
    End If

    ' 새 시트 생성
    Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws.Name = sheetName

    Set targetSheet = ws

    ' 다이어리 생성
    Call SetupPageLayout
    Call CreateDiaryLayout(selectedDate, dayOfWeek)
    Call AddCheckboxes
    Call printPreviewHorizontal
    ' 첫 번째 입력 셀로 이동
    ws.Range("B4").Select

    MsgBox "다이어리가 생성되었습니다!", vbInformation, "완료"
End Sub

' 날짜 유효성 검사
Function IsValidDate(dateStr As String) As Boolean
    Dim parts() As String
    Dim tempDate As Date

    IsValidDate = False

    ' YYYY-MM-DD 형식 확인
    If Len(dateStr) <> 10 Then Exit Function
    If Mid(dateStr, 5, 1) <> "-" Or Mid(dateStr, 8, 1) <> "-" Then Exit Function

    On Error Resume Next
    tempDate = CDate(dateStr)
    If Err.Number = 0 Then
        IsValidDate = True
    End If
    On Error GoTo 0
End Function

' 한글 요일 반환
Function GetKoreanDayOfWeek(targetDate As Date) As String
    Dim dayNum As Integer
    Dim days(1 To 7) As String

    days(1) = "일요일"
    days(2) = "월요일"
    days(3) = "화요일"
    days(4) = "수요일"
    days(5) = "목요일"
    days(6) = "금요일"
    days(7) = "토요일"

    dayNum = Weekday(targetDate)
    GetKoreanDayOfWeek = days(dayNum)
End Function

' 페이지 레이아웃 설정
Sub SetupPageLayout()
    With targetSheet
        ' 열 너비 설정
        .Columns("A").ColumnWidth = 2
        .Columns("B:D").ColumnWidth = 15
        .Columns("E").ColumnWidth = 2
        .Columns("F:N").ColumnWidth = 12
        .Columns("J").ColumnWidth = 6

        ' 행 높이 기본 설정
        .Rows.RowHeight = 21
        .Rows(23).RowHeight = 15
        ' 화면 설정
        ActiveWindow.Zoom = 85
        .Cells.Font.Name = "맑은 고딕"
        .Cells.Font.Size = 10
    End With
End Sub

' 다이어리 레이아웃 생성
Sub CreateDiaryLayout(selectedDate As Date, dayOfWeek As String)
    ' 날짜 헤더 생성
    Call CreateDateHeader(selectedDate, dayOfWeek)

    ' WEEKLY 섹션 생성
    Call CreateWeeklySection

    ' MEMO 섹션 생성
    Call CreateMemoSection

    ' SEE 섹션 생성
    Call CreateSeeSection
End Sub

' 날짜 헤더 생성
Sub CreateDateHeader(selectedDate As Date, dayOfWeek As String)
    With targetSheet
        ' 날짜 표시 셀 병합 (F1:N2)
        .Range("F1:N2").Merge
        .Range("F1").Value = Format(selectedDate, "mm/dd") & " (" & dayOfWeek & ")"
        .Range("F1").HorizontalAlignment = xlCenter
        .Range("F1").VerticalAlignment = xlCenter
        .Range("F1").Font.Size = 16
        .Range("F1").Font.Bold = True

        ' 테두리
        With .Range("F1:N2").Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With

        ' 배경색
        .Range("F1:N2").Interior.Color = RGB(248, 248, 248)
    End With
End Sub

' WEEKLY 섹션 생성
Sub CreateWeeklySection()
    Dim startRow As Integer
    Dim endRow As Integer

    startRow = 1
    endRow = 31

    With targetSheet
        ' WEEKLY 헤더
        .Range("B" & startRow & ":D" & startRow).Merge
        .Range("B" & startRow).Value = "WEEKLY"
        .Range("B" & startRow).HorizontalAlignment = xlCenter
        .Range("B" & startRow).Font.Bold = True
        .Range("B" & startRow).Font.Size = 14

        ' 헤더 테두리
        With .Range("B" & startRow & ":D" & startRow).Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        .Range("B" & startRow).Borders(xlEdgeBottom).Weight = xlMedium

        ' WEEKLY 내용 영역
        .Range("B" & (startRow + 1) & ":D" & endRow).Merge
        .Range("B" & (startRow + 1)).VerticalAlignment = xlTop
        .Range("B" & (startRow + 1)).WrapText = True

        ' 전체 테두리
        With .Range("B" & startRow & ":D" & endRow).Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
    End With
End Sub

' MEMO 섹션 생성
Sub CreateMemoSection()
    Dim startRow As Integer
    Dim currentRow As Integer
    Dim hour As Integer

    startRow = 3
    currentRow = startRow

    With targetSheet
        ' MEMO 헤더
        .Range("F" & currentRow & ":I" & currentRow).Merge
        .Range("K" & currentRow & ":N" & currentRow).Merge
        .Range("F" & currentRow).Value = "PLAN"
        .Range("K" & currentRow).Value = "DO"
        .Range("J" & currentRow).Value = "TIME"
        .Range("F3:N" & currentRow).HorizontalAlignment = xlCenter
        .Range("F3:N" & currentRow).Font.Bold = True
        .Range("F3:N" & currentRow).Interior.Color = RGB(248, 248, 248)

        With .Range("F" & currentRow & ":N" & currentRow).Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With

        currentRow = currentRow + 1

        ' 시간 블록 생성 (6시 ~ 24시)
        For hour = 6 To 24
            ' 시간 표시 (J열)
            .Range("J" & currentRow).Value = hour
            .Range("J" & currentRow).HorizontalAlignment = xlCenter
            .Range("J" & currentRow).VerticalAlignment = xlCenter
            .Range("J" & currentRow).Interior.Color = RGB(250, 250, 250)

            ' 메모 영역 (G:N열 병합)
            .Range("F" & currentRow & ":I" & currentRow).Merge
            .Range("K" & currentRow & ":N" & currentRow).Merge
            .Range("G" & currentRow).WrapText = True
            .Range("F" & currentRow).IndentLevel = 2
            ' 테두리
            With .Range("F" & currentRow & ":N" & currentRow).Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With

            currentRow = currentRow + 1
        Next hour

        ' 외곽 테두리 강조
        With .Range("F" & startRow & ":N" & (currentRow - 1)).Borders
            .LineStyle = xlContinuous
        End With

        .Range("F" & startRow & ":N" & (currentRow - 1)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium

    End With
End Sub

' SEE 섹션 생성
Sub CreateSeeSection()
    Dim startRow As Integer
    Dim seeStartCol As Integer
    Dim colOffset As Integer
    Dim titles As Variant
    Dim i As Integer

    startRow = 24
    seeStartCol = 6 ' F열
    titles = Array("Keep (유지할 것)", "Problem (문제점)", "Try (시도할 것)")

    With targetSheet
        ' SEE 헤더
        .Range("F" & startRow & ":N" & startRow).Merge
        .Range("F" & startRow).Value = "SEE (Keep, Problem, Try)"
        .Range("F" & startRow).Font.Bold = True
        .Range("F" & startRow).HorizontalAlignment = xlCenter

        With .Range("F" & startRow & ":N" & startRow).Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With

        startRow = startRow + 1

        ' Keep, Problem, Try 3개 영역
        For i = 0 To 2
            colOffset = i * 3

            ' 제목
            .Range(.Cells(startRow, seeStartCol + colOffset), .Cells(startRow, seeStartCol + colOffset + 2)).Merge
            .Range(.Cells(startRow, seeStartCol + colOffset), .Cells(startRow, seeStartCol + colOffset + 2)).Value = titles(i)
            .Range(.Cells(startRow, seeStartCol + colOffset), .Cells(startRow, seeStartCol + colOffset + 2)).Font.Bold = True
            .Range(.Cells(startRow, seeStartCol + colOffset), .Cells(startRow, seeStartCol + colOffset + 2)).Interior.Color = RGB(250, 250, 250)

            ' 내용 영역 (6행)
            .Range(.Cells(startRow + 1, seeStartCol + colOffset), .Cells(startRow + 6, seeStartCol + colOffset + 2)).Merge
            .Range(.Cells(startRow + 1, seeStartCol + colOffset), .Cells(startRow + 1, seeStartCol + colOffset + 2)).WrapText = True
            .Range(.Cells(startRow + 1, seeStartCol + colOffset), .Cells(startRow + 1, seeStartCol + colOffset + 2)).VerticalAlignment = xlTop

            ' 테두리
            With .Range(.Cells(startRow, seeStartCol + colOffset), .Cells(startRow + 6, seeStartCol + colOffset + 2)).Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With

            .Range(.Cells(startRow, seeStartCol + colOffset), .Cells(startRow + 6, seeStartCol + colOffset + 2)).BorderAround _
                LineStyle:=xlContinuous, Weight:=xlMedium

        Next i
        .Range("F25:N25").HorizontalAlignment = xlCenter
        ' 전체 SEE 섹션 외곽 테두리
        .Range("F" & (startRow - 1) & ":N" & (startRow + 6)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium

    End With
End Sub

' 체크박스 추가 (F4:F22)
Sub AddCheckboxes()
    Dim i As Integer
    Dim chkBox As CheckBox
    Dim cellRange As Range

    With targetSheet
        ' F4부터 F22까지 체크박스 추가
        For i = 4 To 22
            Set cellRange = .Range("F" & i)

            ' 체크박스 추가
            Set chkBox = .CheckBoxes.Add(cellRange.Left + 2, cellRange.Top + 2, cellRange.Width - 4, cellRange.Height - 4)

            With chkBox
                .Caption = ""  ' 캡션 제거
                .Value = xlOff  ' 체크 해제 상태
                .Display3DShading = False
            End With
        Next i
    End With
End Sub

Private Sub printPreviewHorizontal()
    Dim sht As Worksheet
    If Workbooks.Count < 1 Then
        MsgBox "열려있는 파일이 없습니다."
        Exit Sub
    End If


    For Each sht In ActiveWindow.SelectedSheets
        With sht.PageSetup
                .LeftMargin = Application.InchesToPoints(0.3):
                .RightMargin = Application.InchesToPoints(0.5)
                .TopMargin = Application.InchesToPoints(0.5):
                .BottomMargin = Application.InchesToPoints(0.4)
                .HeaderMargin = Application.InchesToPoints(0.315):
                .FooterMargin = Application.InchesToPoints(0.197)
                .CenterHorizontally = True
                .Orientation = xlLandscape:
                .PrintComments = xlPrintInPlace
                .Zoom = False:
                .FitToPagesWide = 1:
                .FitToPagesTall = False
        End With
    Next sht

'    ActiveWindow.SelectedSheets.PrintPreview

End Sub

3. 실행

Alt + F8 키로 매크로 실행 창 열기
CreatePDSDiary 선택 후 실행
날짜 입력 (예: 2025-10-27)

주의사항

시트 이름 중복: 같은 날짜의 다이어리는 생성되지 않습니다
체크박스 개수: 시간 블록 개수에 맞춰 자동 조정됩니다
인쇄 설정: 가로 방향, A4 용지 기준으로 최적화되어 있습니다

PDS 다이어리.xlsm

엑셀 VBA로 불필요한 행 자동 삭제 하기

노만e — Sun, 19 Oct 2025 13:33:49 +0900

들어가며

대량의 엑셀 데이터에서 특정 항목이 포함된 행을 일괄 삭제해야 할 때가 있으신가요? 수백, 수천 개의 행을 일일이 찾아 삭제하는 것은 시간 낭비이자 실수의 위험이 큽니다.

오늘은 불필요한 데이터 행을 자동으로 찾아 삭제하고 정렬까지 해주는 VBA 매크로를 소개합니다. 이 매크로 하나면 복잡한 데이터 정리 작업이 클릭 몇 번으로 끝납니다!

매크로 주요 기능

✨ 핵심 기능 한눈에 보기

✅ 다중 항목 일괄 삭제 - 여러 개의 제거 항목을 한 번에 처리
✅ 시각적 확인 - 삭제될 행을 빨간색으로 표시하여 사전 확인
✅ 안전한 삭제 - 자동필터를 활용한 정확한 행 삭제
✅ 자동 정렬 - 삭제 후 첫 번째 열 기준 오름차순 정렬
✅ 진행 상황 보고 - 삭제된 행 개수와 처리 결과 안내
✅ 유연한 범위 설정 - 원하는 데이터 범위와 기준 열 자유 선택

Sub 불필요한데이터행삭제2()
    Dim ws As Worksheet
    Dim 제거항목범위 As Range
    Dim 데이터범위 As Range
    Dim 삭제열범위 As Range
    Dim 삭제열 As Long
    Dim 제거항목 As Variant
    Dim 제거항목배열() As String
    Dim i As Long, j As Long
    Dim 마지막행 As Long
    Dim 찾은셀 As Range
    Dim 첫주소 As String
    Dim 색칠개수 As Long
    Dim 항목개수 As Long
    Dim 데이터시작열 As Long
    Dim 데이터끝열 As Long

    Set ws = ActiveSheet

    On Error Resume Next

    ' 1단계: 데이터 범위 선택
    Set 데이터범위 = Application.InputBox("전체 데이터 범위를 선택하세요" & vbCrLf & "(헤더 포함)", "데이터 범위 선택", Type:=8)
    If 데이터범위 Is Nothing Then
        MsgBox "취소되었습니다."
        Exit Sub
    End If

    If ws.AutoFilterMode Then
        데이터범위.Cells(1, 1).AutoFilter
    End If

    데이터시작열 = 데이터범위.Column
    데이터끝열 = 데이터범위.Column + 데이터범위.Columns.Count - 1
    마지막행 = 데이터범위.Row + 데이터범위.Rows.Count - 1

    ' 2단계: 삭제할 데이터가 있는 열 선택
    Set 삭제열범위 = Application.InputBox("삭제할 데이터가 있는 열의 셀을 하나 선택하세요" & vbCrLf & "(해당 열의 아무 셀이나 클릭)", "삭제 기준 열 선택", Type:=8)
    If 삭제열범위 Is Nothing Then
        MsgBox "취소되었습니다."
        Exit Sub
    End If

    ' 선택한 범위의 첫 번째 셀의 열 번호 가져오기
    삭제열 = 삭제열범위.Cells(1, 1).Column

    ' 삭제열이 데이터 범위 내에 있는지 확인
    If 삭제열 < 데이터시작열 Or 삭제열 > 데이터끝열 Then
        MsgBox "선택한 열이 데이터 범위 내에 없습니다.", vbExclamation
        Exit Sub
    End If

    ' 3단계: 제거할 항목 범위 선택
    Set 제거항목범위 = Application.InputBox("제거할 항목이 있는 범위를 선택하세요", "제거 항목 범위 선택", Type:=8)
    If 제거항목범위 Is Nothing Then
        MsgBox "취소되었습니다."
        Exit Sub
    End If

    ' 제거할 항목을 배열로 저장
    항목개수 = 0
    ReDim 제거항목배열(1 To 제거항목범위.Cells.Count)

    For Each 제거항목 In 제거항목범위
        If 제거항목.Value <> "" Then
            항목개수 = 항목개수 + 1
            제거항목배열(항목개수) = CStr(제거항목.Value)
        End If
    Next 제거항목

    If 항목개수 = 0 Then
        MsgBox "제거할 항목이 없습니다."
        Exit Sub
    End If

    ReDim Preserve 제거항목배열(1 To 항목개수)

    Application.ScreenUpdating = False

    ' 4단계: 제거할 항목과 일치하는 셀에 빨간색 칠하기
    색칠개수 = 0

    For i = 데이터범위.Row + 1 To 마지막행  ' 헤더 제외
        For j = 1 To 항목개수
            If ws.Cells(i, 삭제열).Value = 제거항목배열(j) Then
                ws.Cells(i, 삭제열).Interior.Color = RGB(255, 0, 0)
                색칠개수 = 색칠개수 + 1
                Exit For
            End If
        Next j
    Next i

    ' 5단계: 모든 제거 항목이 색칠되었는지 확인
    Dim 항목확인개수 As Long
    항목확인개수 = 0

    For j = 1 To 항목개수
        Set 찾은셀 = ws.Range(ws.Cells(데이터범위.Row + 1, 삭제열), ws.Cells(마지막행, 삭제열)).Find(What:=제거항목배열(j), LookIn:=xlValues, LookAt:=xlWhole)
        If Not 찾은셀 Is Nothing Then
            첫주소 = 찾은셀.Address
            Do
                If 찾은셀.Interior.Color = RGB(255, 0, 0) Then
                    항목확인개수 = 항목확인개수 + 1
                    Exit Do
                End If
                Set 찾은셀 = ws.Range(ws.Cells(데이터범위.Row + 1, 삭제열), ws.Cells(마지막행, 삭제열)).FindNext(찾은셀)
            Loop While Not 찾은셀 Is Nothing And 찾은셀.Address <> 첫주소
        End If
    Next j

    If 항목확인개수 < 항목개수 Then
        MsgBox "일부 제거 항목이 데이터에서 발견되지 않았습니다." & vbCrLf & _
               "발견된 항목: " & 항목확인개수 & " / " & 항목개수, vbExclamation
    End If

    ' 6단계: 자동필터 적용 및 빨간색 행 삭제
    If 색칠개수 > 0 Then
        ' 기존 필터 제거
        If ws.AutoFilterMode Then ws.AutoFilterMode = False

        ' 자동필터 적용
        데이터범위.AutoFilter

        ' 삭제열의 필드 번호 계산 (데이터범위 내에서의 상대적 위치)
        Dim 필드번호 As Long
        필드번호 = 삭제열 - 데이터시작열 + 1

        ' 빨간색으로 칠해진 셀 필터링
        데이터범위.AutoFilter Field:=필드번호, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor

        ' 필터된 행 삭제 (헤더 제외)
        On Error Resume Next
        Dim 삭제범위 As Range
        Set 삭제범위 = ws.Range(ws.Cells(데이터범위.Row + 1, 데이터시작열), ws.Cells(마지막행, 데이터끝열))
        삭제범위.SpecialCells(xlCellTypeVisible).EntireRow.Clear
        On Error GoTo 0

        ' 필터 해제
        데이터범위.Cells(1, 1).AutoFilter

        ' 새로운 마지막 행 찾기
        마지막행 = ws.Cells(ws.Rows.Count, 데이터시작열).End(xlUp).Row

        ' 7단계: A열 기준 오름차순 정렬
        If 마지막행 > 데이터범위.Row Then
            Set 데이터범위 = ws.Range(ws.Cells(데이터범위.Row, 데이터시작열), ws.Cells(마지막행, 데이터끝열))
            데이터범위.Sort Key1:=ws.Cells(데이터범위.Row, 데이터시작열), Order1:=xlAscending, Header:=xlYes
        End If

        MsgBox 색칠개수 & "개의 행이 삭제되었고, 첫 번째 열 기준으로 정렬되었습니다.", vbInformation
    Else
        MsgBox "삭제할 데이터가 없습니다.", vbInformation
    End If

    Application.ScreenUpdating = True

End Sub

사용 방법 상세 가이드

Step 1: VBA 편집기 열기

엑셀 파일 열기
Alt + F11 키를 눌러 VBA 편집기 실행
삽입 > 모듈 선택
위의 코드를 복사하여 붙여넣기

Step 2: 매크로 실행

Alt + F8 키를 눌러 매크로 대화상자 열기
불필요한데이터행삭제2 선택 후 실행 클릭

Step 3: 데이터 범위 선택

첫 번째 대화상자가 나타나면:

삭제 작업을 수행할 전체 데이터 범위를 드래그하여 선택
⚠️ 헤더(제목 행)를 반드시 포함해야 합니다
예: A1:F100 (A열부터 F열까지, 1행부터 100행까지)

text복사

┌─────────┬─────────┬─────────┬─────────┐
│ 이름    │ 부서    │ 상태    │ 금액    │ ← 헤더 포함!
├─────────┼─────────┼─────────┼─────────┤
│ 홍길동  │ 영업    │ 완료    │ 10000   │
│ 김철수  │ 개발    │ 대기    │ 20000   │
└─────────┴─────────┴─────────┴─────────┘

Step 4: 삭제 기준 열 선택

두 번째 대화상자가 나타나면:

삭제 기준이 되는 열의 아무 셀이나 클릭
예: "상태" 열에서 특정 값을 가진 행을 삭제하려면 "상태" 열의 아무 셀이나 클릭

text복사

예시: C열(상태)을 기준으로 삭제하려면 C열의 아무 셀이나 클릭

Step 5: 제거할 항목 선택

세 번째 대화상자가 나타나면:

삭제하고 싶은 항목들이 나열된 범위를 선택
여러 셀을 선택할 수 있습니다 (연속/불연속 모두 가능)

text복사

예시: 제거할 항목 목록
┌─────────┐
│ 대기    │
│ 취소    │
│ 보류    │
└─────────┘
이 범위를 선택하면 "대기", "취소", "보류" 상태인 모든 행이 삭제됩니다.

Step 6: 자동 처리 및 결과 확인

매크로가 자동으로:

✅ 해당 항목이 있는 행을 빨간색으로 표시
✅ 자동필터를 적용하여 빨간색 행만 삭제
✅ 첫 번째 열 기준으로 오름차순 정렬
✅ 삭제된 행 개수를 메시지로 표시

불필요한 데이터 삭제.xlsm

엑셀 VBA로 색상별 셀 선택 후 다중 영역 복사/붙여넣 - 실무 자동화 완벽 가이드

노만e — Sat, 18 Oct 2025 16:24:28 +0900

들어가며

엑셀 작업 중 특정 색상의 셀만 선택하거나, 불연속적인 범위를 열 단위로 정리해야 할 때가 있으신가요? 수작업으로 하면 시간도 오래 걸리고 실수하기도 쉽죠. 오늘은 이런 반복 작업을 VBA 매크로로 자동화하는 방법을 소개합니다.

이 글에서는 두 가지 강력한 VBA 코드를 제공합니다:

색상별 셀 자동 선택 매크로 - 배경색이나 글꼴색이 같은 셀을 한 번에 선택
선택 범위 열 단위 복사 매크로 - 불연속 범위를 깔끔하게 열 단위로 정리

1. 색상별 셀 자동 선택 매크로 (SelectSameColorCellsAdvanced2)

기능 소개

이 매크로는 특정 색상의 셀을 자동으로 찾아 선택해주는 도구입니다.

주요 기능:

✅ 배경색 또는 글꼴색 선택 가능
✅ 사용 중인 영역 자동 인식 또는 수동 범위 지정
✅ 기준 셀 선택만으로 같은 색상 일괄 선택
✅ 선택된 셀 개수 자동 카운트

사용 방법

Step 1: VBA 편집기 열기

Alt + F11 키를 눌러 VBA 편집기를 엽니다
삽입 > 모듈을 선택하여 새 모듈을 만듭니다

Step 2: 코드 입력

Sub SelectSameColorCellsAdvanced2()
    Dim searchRange As Range
    Dim colorCell As Range
    Dim targetColor As Long
    Dim cell As Range
    Dim resultRange As Range
    Dim response As VbMsgBoxResult
    Dim colorType As String

    ' 1. 범위 선택 방식 결정
    response = MsgBox("현재 사용 중인 영역을 자동으로 선택하시겠습니까?" & vbCrLf & vbCrLf & _
                      "예 = 사용 중인 영역 자동 선택" & vbCrLf & _
                      "아니오 = 직접 범위 선택", vbYesNoCancel + vbQuestion, "범위 선택")

    If response = vbCancel Then Exit Sub

    ' 검색 범위 설정
    If response = vbYes Then
        Set searchRange = ActiveSheet.UsedRange
        MsgBox "검색 범위: " & searchRange.Address & vbCrLf & _
               "(" & searchRange.Rows.Count & "행 x " & searchRange.Columns.Count & "열)", vbInformation
    Else
        On Error Resume Next
        Set searchRange = Application.InputBox("검색할 범위를 선택하세요", "범위 선택", Type:=8)
        On Error GoTo 0

        If searchRange Is Nothing Then Exit Sub
    End If

    ' 2. 색상 유형 선택 (배경색 or 글꼴색)
    response = MsgBox("어떤 색상을 기준으로 하시겠습니까?" & vbCrLf & vbCrLf & _
                      "예 = 배경색" & vbCrLf & _
                      "아니오 = 글꼴색", vbYesNoCancel + vbQuestion, "색상 유형")

    If response = vbCancel Then Exit Sub

    If response = vbYes Then
        colorType = "배경색"
    Else
        colorType = "글꼴색"
    End If

    On Error Resume Next
    Set colorCell = Application.InputBox(colorType & " 기준 셀을 선택하세요", "색상 선택", Type:=8)
    On Error GoTo 0

    If colorCell Is Nothing Then Exit Sub

    ' 선택한 셀의 색상 가져오기
    If colorType = "배경색" Then
        targetColor = colorCell.Interior.Color
    Else
        targetColor = colorCell.Font.Color
    End If

    ' 4. 같은 색상의 셀 찾기
    For Each cell In searchRange
        Dim cellColor As Long

        If colorType = "배경색" Then
            cellColor = cell.Interior.Color
        Else
            cellColor = cell.Font.Color
        End If

        If cellColor = targetColor Then
            If resultRange Is Nothing Then
                Set resultRange = cell
            Else
                Set resultRange = Union(resultRange, cell)
            End If
        End If
    Next cell

    ' 5. 결과 표시
    If resultRange Is Nothing Then
        MsgBox "같은 " & colorType & "의 셀을 찾을 수 없습니다.", vbExclamation
    Else
        resultRange.Select
        MsgBox "같은 " & colorType & "의 셀 " & resultRange.Cells.Count & "개를 선택했습니다.", vbInformation
    End If
End Sub

Step 3: 매크로 실행

Alt + F8 키를 눌러 매크로 대화상자를 엽니다
SelectSameColorCellsAdvanced2를 선택하고 실행합니다
안내에 따라 범위와 색상을 선택합니다

활용 예시

데이터 분석 시나리오:

노란색으로 표시된 중요 데이터만 추출
빨간색 글꼴로 표시된 오류 항목 일괄 수정
초록색 배경의 완료 항목 카운트

2. 선택 범위 열 단위 복사 매크로 (CopyRangesByColumnScan2)

기능 소개

불연속적으로 선택된 셀들을 열 단위로 정리하여 복사하는 매크로입니다.

주요 기능:

✅ 불연속 범위 자동 인식
✅ 열 순서대로 데이터 정리
✅ 빈 열 자동 제거
✅ 원하는 위치에 깔끔하게 붙여넣기

사용 방법

코드 입력

Sub CopyRangesByColumnScan2()
    Dim targetRange As Range
    Dim minCol As Long, maxCol As Long
    Dim minRow As Long, maxRow As Long
    Dim currentCol As Long
    Dim outputCol As Long
    Dim outputRow As Long
    Dim cell As Range
    Dim area As Range

    ' 선택 범위 확인
    If Selection Is Nothing Then
        MsgBox "범위를 선택해주세요.", vbExclamation
        Exit Sub
    End If

    ' 붙여넣을 시작 위치 선택
    On Error Resume Next
    Set targetRange = Application.InputBox("붙여넣을 시작 위치를 선택하세요", Type:=8)
    On Error GoTo 0

    If targetRange Is Nothing Then Exit Sub

    ' 선택 범위의 최소/최대 열과 행 찾기
    minCol = Selection.Areas(1).Column
    maxCol = Selection.Areas(1).Column + Selection.Areas(1).Columns.Count - 1
    minRow = Selection.Areas(1).Row
    maxRow = Selection.Areas(1).Row + Selection.Areas(1).Rows.Count - 1

    For Each area In Selection.Areas
        If area.Column < minCol Then minCol = area.Column
        If area.Column + area.Columns.Count - 1 > maxCol Then maxCol = area.Column + area.Columns.Count - 1
        If area.Row < minRow Then minRow = area.Row
        If area.Row + area.Rows.Count - 1 > maxRow Then maxRow = area.Row + area.Rows.Count - 1
    Next area

    Application.ScreenUpdating = False

    outputCol = 0

    ' 각 열을 순회
    For currentCol = minCol To maxCol
        outputRow = 0

        ' 해당 열에 선택된 셀이 있는지 확인하고 복사
        Dim Row As Long
        For Row = minRow To maxRow
            Dim checkCell As Range
            Set checkCell = Cells(Row, currentCol)

            ' 선택 범위에 포함되어 있는지 확인
            If IsCellInSelection(checkCell, Selection) Then
                ' 값 복사
                targetRange.Offset(outputRow, outputCol).Value = checkCell.Value
                outputRow = outputRow + 1
            End If
        Next Row

        ' 해당 열에 데이터가 있었다면 다음 출력 열로 이동
        If outputRow > 0 Then
            outputCol = outputCol + 1
        End If
    Next currentCol

    Application.ScreenUpdating = True

    MsgBox "복사/붙여넣기 완료!", vbInformation
End Sub

' 셀이 선택 범위에 포함되어 있는지 확인하는 함수
Function IsCellInSelection(cell As Range, Selection As Range) As Boolean
    Dim area As Range
    IsCellInSelection = False

    For Each area In Selection.Areas
        If Not Intersect(cell, area) Is Nothing Then
            IsCellInSelection = True
            Exit Function
        End If
    Next area
End Function

실행 방법

정리하고 싶은 셀들을 Ctrl 키를 누른 채 선택합니다
Alt + F8로 매크로 실행
CopyRangesByColumnScan2 선택
붙여넣을 위치를 클릭합니다

활용 예시

실무 활용 사례:

여러 시트에서 수집한 데이터를 하나로 정리
색상별로 선택한 셀들을 별도 영역에 정리
필터링된 데이터를 깔끔하게 재배치

두 매크로 연계 활용법

완벽한 워크플로우

Step 1: SelectSameColorCellsAdvanced2 실행

노란색 배경 셀 모두 선택

Step 2: CopyRangesByColumnScan2 실행

선택된 셀들을 새 위치에 열 단위로 정리

결과: 색상별로 분류된 데이터가 깔끔하게 정리됩니다!

보안 설정 안내

매크로 사용 설정 방법

파일 > 옵션 > 보안 센터
보안 센터 설정 > 매크로 설정
"모든 매크로 포함" 또는 "디지털 서명된 매크로만" 선택

⚠️ 주의: 신뢰할 수 있는 매크로만 실행하세요!

마치며

오늘 소개한 두 가지 VBA 매크로는 엑셀 실무에서 반복 작업 시간을 획기적으로 단축시켜줍니다.

핵심 요약:

✅ 색상별 셀 자동 선택으로 데이터 분류 자동화
✅ 열 단위 복사로 불연속 데이터 정리
✅ 두 매크로 연계로 완벽한 데이터 정리 워크플로우 구축

코드를 복사해서 바로 사용하시고, 필요에 따라 커스터마이징해보세요.

같은 색상의 셀만 선택_복사붙여넣기.xlsm

Excel VBA 매크로로 셀 크기 자동 조정하기.xlsm

Excel VBA 매크로로 셀 크기 자동 조정하기 - 업무 효율 10배 높이는 방법

노만e — Sat, 4 Oct 2025 11:51:36 +0900

들어가며

Excel 작업을 하다 보면 셀 크기 조정 때문에 시간을 많이 낭비하게 됩니다. 특히 대량의 데이터를 다룰 때 일일이 행 높이와 열 너비를 조정하는 것은 정말 번거로운 일이죠.

오늘은 VBA 매크로를 활용해서 이런 반복 작업을 자동화하는 방법을 알려드리겠습니다. 한 번 설정해두면 클릭 한 번으로 모든 셀 크기가 자동으로 조정됩니다!

이런 분들에게 추천합니다

Excel로 보고서를 자주 만드는 직장인
대량의 데이터를 정리해야 하는 분석가
반복 작업을 줄이고 싶은 모든 Excel 사용자

기본 VBA 매크로 코드

먼저 가장 기본적인 자동 조정 매크로부터 살펴보겠습니다.

vba복사

Sub QuickAutoFit()

On Error Resume Next

With Selection.CurrentRegion

.WrapText = False

.ShrinkToFit = False

.Rows.AutoFit

.Columns.AutoFit

End With

On Error GoTo 0

End Sub

코드 설명

Selection.CurrentRegion: 현재 선택된 셀 주변의 연결된 데이터 영역
WrapText = False: 자동 줄 바꿈 해제
Rows.AutoFit: 행 높이 자동 조정
Columns.AutoFit: 열 너비 자동 조정

고급 버전 매크로

더 많은 기능이 포함된 고급 버전도 준비했습니다.

vba복사

Sub AdvancedAutoFit()

Dim selectedRange As Range

Dim targetRange As Range

Dim startTime As Double

startTime = Timer

On Error GoTo ErrorHandler

Set selectedRange = Selection

' 성능 최적화

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

With selectedRange.CurrentRegion

.WrapText = False

.ShrinkToFit = False

.Rows.AutoFit

.Columns.AutoFit

' 크기 제한 설정

Dim col As Range

For Each col In .Columns

If col.ColumnWidth > 50 Then col.ColumnWidth = 50

If col.ColumnWidth < 8 Then col.ColumnWidth = 8

Next col

End With

' 실행 시간 표시

Application.StatusBar = "자동 조정 완료! (실행시간: " & _

Format(Timer - startTime, "0.00") & "초)"

GoTo CleanUp

ErrorHandler:

MsgBox "오류 발생: " & Err.Description, vbCritical

CleanUp:

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub

매크로 등록 및 사용법

1단계: VBA 편집기 열기

Alt + F11 키를 눌러 VBA 편집기를 엽니다
또는 개발 도구 탭 → Visual Basic 클릭

2단계: 모듈 삽입

삽입 → 모듈 선택
새로운 모듈 창이 열립니다

3단계: 코드 입력

위의 코드를 복사해서 붙여넣기
Ctrl + S로 저장

4단계: 매크로 실행

Alt + F8 → 매크로 선택 → 실행
또는 단축키 설정 후 사용

단축키 설정하기

매번 Alt + F8을 누르기 번거롭다면 단축키를 설정해보세요.

Alt + F8 → 매크로 선택
옵션 버튼 클릭
원하는 단축키 입력 (예: Ctrl + Shift + A)
확인 클릭

이제 Ctrl + Shift + A만 누르면 자동 조정이 실행됩니다!

활용 예시

Before (수동 조정)

text복사

시간 소요: 5분
작업 단계: 10단계
실수 가능성: 높음

After (매크로 사용)

text복사

시간 소요: 3초
작업 단계: 1단계 (단축키 하나)
실수 가능성: 없음

효율성 개선: 약 100배 빨라짐!

⚠️ 주의사항

백업 필수: 매크로 실행 전 파일을 백업하세요
매크로 보안: 신뢰할 수 있는 매크로만 실행하세요
대용량 데이터: 너무 큰 데이터는 실행 시간이 오래 걸릴 수 있습니다

추가 팁

리본 메뉴에 추가하기

파일 → 옵션 → 리본 사용자 지정
매크로 선택 → 추가
이제 리본에서 바로 클릭 가능!

여러 시트에 적용하기

vba복사

Sub AutoFitAllSheets()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

ws.Cells.AutoFit

Next ws

End Sub

마무리

Excel VBA 매크로를 활용하면 반복적인 셀 크기 조정 작업을 완전히 자동화할 수 있습니다.

처음에는 코드가 어려워 보일 수 있지만, 한 번 설정해두면 업무 효율이 크게 향상됩니다. 특히 매일 Excel 작업을 하는 분들에게는 정말 유용한 도구가 될 것입니다.

여러분도 오늘부터 매크로를 활용해서 스마트한 Excel 사용자가 되어보세요!

엑셀로 만드는 미로 탈출 게임 (VBA 매크로 활용)

노만e — Wed, 1 Oct 2025 22:39:12 +0900

안녕하세요! 오늘은 단순한 업무 프로그램을 넘어서, Excel VBA로 만든 재미있는 미로 탈출 게임을 소개해드리겠습니다.
업무에만 쓰이던 엑셀에서 직접 게임을 즐길 수 있다는 사실, 놀랍지 않나요?

게임 특징

랜덤 미로 생성 : 매번 새로운 맵에서 플레이 가능
방향키 조작(↑↓←→) : 직관적인 플레이
시간 측정 기능 : 클리어까지 걸린 시간 확인
클리어 후 재시작 여부 선택 : 무한 반복 가능

⚙️ 설치 및 실행 방법

Excel을 열고 Alt + F11을 눌러 VBA 편집기를 실행합니다.
삽입 > 모듈을 클릭한 후, 제공된 코드를 전체 복사 & 붙여넣기 합니다.
Alt + F11로 Excel로 돌아옵니다.
Alt + F8을 눌러 StartGame 매크로를 실행합니다.
이제 방향키로 ★ 캐릭터를 움직여 ◎ 출구까지 도달하면 됩니다!

게임 규칙

★ : 플레이어
◎ : 출구
■ : 벽
목표 : 벽을 피해서 출구까지 이동

클리어 시 걸린 시간이 표시되며, 원한다면 바로 새로운 미로를 시작할 수 있습니다.

️ 코드 다운로드

코드 전문은 아래에서 확인하실 수 있습니다.
(블로그 본문에 전체 코드 첨부)

✨ 응용 아이디어

난이도 설정 : 미로 크기를 조절해 초급~고급 난이도로 확장
점수 시스템 : 이동 횟수, 시간 기반 점수 랭킹
기록 저장 : 클리어 기록을 자동으로 다른 시트에 저장

마무리

엑셀은 단순한 데이터 관리 도구를 넘어서, 이렇게 작은 게임 플랫폼으로도 활용할 수 있습니다.
게임을 통해 VBA 학습까지 할 수 있으니 일석이조죠!

직접 실행해보시고, 재밌게 즐기셨다면 댓글로 기록한 클리어 시간을 공유해주세요!
더 다양한 엑셀 게임/자동화 팁을 받아보고 싶다면 이웃 추가 & 구독 잊지 마세요.

미로게임.xlsm

Excel 시트를 PowerPoint 슬라이드로 내보내기.xlsm

️ 엑셀 각 시트의 인쇄영역을 PowerPoint로 내보내는 VBA 매크로 대공개!

노만e — Sat, 27 Sep 2025 20:00:34 +0900

보고서용 슬라이드 매번 복사해서 붙여넣고 계신가요?
이제 엑셀에서 인쇄영역만 똑똑하게 추출해서 파워포인트로 자동 전환해보세요!
수작업은 그만! 단 1초면 OK!

이 매크로가 뭐길래?

이 Excel VBA 매크로는 엑셀 파일 내 각 시트의 인쇄영역만 추출하여
슬라이드 형태로 PowerPoint 프레젠테이션으로 자동 저장해줍니다.

✔️ PPT 작업시간 90% 절감
✔️ 데이터 기반 보고서 제작에 최적
✔️ 엑셀 인쇄영역만 추출하기 때문에 깨끗한 슬라이드 출력!

✅ 주요 기능 한눈에 보기

기능설명

인쇄영역만 추출	각 시트의 PageSetup.PrintArea 만 PPT에 삽입
자동 슬라이드 생성	시트 개수만큼 슬라이드 자동 생성
슬라이드 제목 삽입	슬라이드 좌측 상단에 시트 이름 삽입
크기 자동 조정	슬라이드에 맞춰 비율 유지하며 자동 맞춤
자동 저장	엑셀 파일명과 같은 이름으로 .pptx 저장

️ 사용 방법 (Step by Step)

매크로 삽입
- Alt + F11 → 모듈 추가 → 코드 붙여넣기
인쇄영역 설정
- 각 시트에서 출력할 범위를 페이지 레이아웃 > 인쇄영역 설정으로 지정
매크로 실행
- Alt + F8 → ExportSheetsToPowerPoint 실행
자동 실행 결과 확인
- PowerPoint 자동 실행 + .pptx 자동 저장 완료!

출력물 예시

슬라이드마다 엑셀 시트 인쇄영역이 꽉 차게 삽입됨
상단에는 시트 이름이 제목처럼 삽입됨
원본 비율 유지로 데이터 왜곡 없이 깔끔하게 정렬

파일 저장 위치

PowerPoint 파일은 현재 엑셀 파일과 같은 경로에 자동 저장
예: 보고서.xlsx → 보고서.pptx

❗ 주의사항

인쇄영역이 없는 시트는 건너뜁니다 (자동 스킵)
숨겨진 시트는 자동 제외되어 안전하게 출력됩니다
pptx 저장 형식으로 자동 저장되며 기존 파일은 덮어쓰지 않음

활용 예시

‍ 월간 보고서 요약본 PPT 출력
실적/성과 데이터 시각화 발표 자료
️ 공정 시트별 브리핑 슬라이드 생성
교육 자료 PPT로 전환

VBA 코드

Sub ExportSheetsToPowerPoint()
    Dim xlApp As Application
    Dim xlWB As Workbook
    Dim xlWS As Worksheet
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim i As Integer
    Dim totalSheets As Integer
    Dim processedSheets As Integer
    Dim pptFileName As String
    Dim excelPath As String
    Dim excelName As String

    ' 에러 처리 추가
    On Error GoTo ErrorHandler

    ' Excel 애플리케이션 및 워크북 설정
    Set xlApp = Application
    Set xlWB = ActiveWorkbook

    ' 총 시트 수 저장
    totalSheets = xlWB.Worksheets.Count
    processedSheets = 0

    ' 엑셀 파일 경로와 이름 추출
    excelPath = xlWB.Path
    excelName = Left(xlWB.Name, InStrRev(xlWB.Name, ".") - 1) ' 확장자 제거
    pptFileName = excelPath & "\" & excelName & ".pptx"

    ' PowerPoint 애플리케이션 생성
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
    End If
    On Error GoTo 0

    ' PowerPoint를 화면에 표시
    pptApp.Visible = True

    ' 새 프레젠테이션 생성
    Set pptPres = pptApp.Presentations.Add

    ' 각 시트를 순회하며 슬라이드로 복사
    For i = 1 To xlWB.Worksheets.Count
        Set xlWS = xlWB.Worksheets(i)

        ' 숨겨진 시트는 건너뛰기
        If xlWS.Visible = xlSheetVisible Then
            Application.StatusBar = "처리 중: " & xlWS.Name & " (" & i & "/" & totalSheets & ")"

            ' 시트 선택 및 인쇄영역 복사
            xlWS.Activate

            ' 인쇄영역이 설정되어 있는지 확인
            If xlWS.PageSetup.PrintArea <> "" Then
                ' 인쇄영역 선택 및 복사
                xlWS.Range(xlWS.PageSetup.PrintArea).Copy

                ' 새 슬라이드 추가 (빈 레이아웃)
                Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, 12) ' 12 = ppLayoutBlank

                ' 슬라이드에 붙여넣기 (그림으로)
                pptSlide.Shapes.PasteSpecial DataType:=2 ' ppPasteEnhancedMetafile

                ' 붙여넣은 개체의 크기와 위치 조정
                If pptSlide.Shapes.Count > 0 Then
                    With pptSlide.Shapes(pptSlide.Shapes.Count)
                        ' 슬라이드 크기에 맞게 조정 (여백 고려)
                        Dim slideWidth As Single
                        Dim slideHeight As Single
                        slideWidth = pptPres.PageSetup.slideWidth
                        slideHeight = pptPres.PageSetup.slideHeight

                        ' 비율을 유지하면서 크기 조정
                        Dim scaleWidth As Single
                        Dim scaleHeight As Single
                        scaleWidth = (slideWidth - 40) / .Width  ' 좌우 여백 20씩
                        scaleHeight = (slideHeight - 40) / .Height  ' 상하 여백 20씩

                        ' 더 작은 비율을 사용하여 슬라이드 안에 맞추기
                        Dim scaleRatio As Single
                        scaleRatio = Application.Min(scaleWidth, scaleHeight)

                        If scaleRatio < 1 Then
                            .Width = .Width * scaleRatio
                            .Height = .Height * scaleRatio
                        End If

                        ' 중앙 정렬
                        .Left = (slideWidth - .Width) / 2
                        .Top = (slideHeight - .Height) / 2
                    End With
                End If

                ' 슬라이드 제목 추가 (선택사항)
                Dim titleShape As Object
                Set titleShape = pptSlide.Shapes.AddTextbox(1, 10, 10, 200, 30) ' msoTextOrientationHorizontal = 1
                With titleShape.TextFrame.TextRange
                    .Text = xlWS.Name
                    .Font.Size = 18
                    .Font.Bold = True
                End With

                Application.CutCopyMode = False
                processedSheets = processedSheets + 1
            Else
                ' 인쇄영역이 설정되지 않은 경우 메시지 (선택사항)
                Debug.Print xlWS.Name & " 시트에는 인쇄영역이 설정되지 않았습니다."
            End If
        End If
    Next i

    ' 첫 번째 슬라이드로 이동
    If pptPres.Slides.Count > 0 Then
        pptPres.Slides(1).Select
    End If

    ' PowerPoint 파일 저장
    pptPres.SaveAs pptFileName

    ' 메시지 박스용 변수 저장 (객체 해제 전에)
    totalSheets = xlWB.Worksheets.Count

    ' 정리
    Application.StatusBar = False
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing

    MsgBox "Excel 인쇄영역을 PowerPoint로 내보내기가 완료되었습니다!" & vbCrLf & _
           "총 " & totalSheets & "개 시트 중 " & processedSheets & "개의 인쇄영역을 처리했습니다." & vbCrLf & _
           "저장 위치: " & pptFileName, vbInformation

    Exit Sub

ErrorHandler:
    Application.StatusBar = False
    Application.CutCopyMode = False
    MsgBox "오류가 발생했습니다: " & Err.Description & " (에러 번호: " & Err.Number & ")", vbCritical

    ' 객체 정리
    On Error Resume Next
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

0.81MB

자재명판 라벨문서 만들기(회사용)

노만e — Thu, 25 Sep 2025 22:25:14 +0900

엑셀 자재명판 자동생성 매크로 - 좌우 레이아웃으로 이미지까지 완성!

복잡한 자재 정보와 사진을 하나하나 배치하고 계신가요?
이제는 클릭 한 번으로 사진 + 자재정보가 자동으로 좌우 정렬되는 엑셀 매크로를 사용해보세요.

✅ 이 매크로는 무엇을 하나요?

이 VBA 매크로는 엑셀에서 자재 데이터를 기반으로 아래와 같은 자동화 작업을 수행합니다:

작업설명

자재목록 불러오기	자재목록 시트에서 자재번호, 품명, 규격 등 읽기
️ 이미지 자동 삽입	자재번호와 일치하는 파일명을 가진 이미지를 폴더에서 자동 불러오기
좌우 배치	하나의 블록에 좌측/우측에 자재 정보와 이미지를 나눠 표시
✂️ 자동 백업	기존 출력 시트를 자동 백업하고 새로운 시트 생성
자동 정리	이전 사진 제거 및 셀 초기화로 깔끔한 출력물 생성

왜 이 매크로가 필요할까요?

자재 사진을 수작업으로 붙이고 텍스트를 입력하는 작업, 지치셨죠?

1분이면 자재명판 100개 출력 준비 끝
반복 작업에서 완전 해방
깔끔하고 통일된 출력 양식

️ 사용 방법

① 시트 구성

자재목록 시트: 자재번호, 품명, 규격 등 자재 데이터 입력
자재사진통합 시트: 1~9행 레이아웃 템플릿 준비 (좌우 구조 포함)

② 매크로 실행

Alt + F11 → 모듈 추가 후 코드 붙여넣기
Alt + F8 → 자재명판_자동생성_좌우레이아웃 실행
시작행/종료행 입력
이미지 폴더 선택
완성된 출력물을 확인!

️ 출력 레이아웃 예시

홀수 개 자재일 경우 마지막 오른쪽은 자동 비워짐
각 블록마다 정확한 행 높이 적용으로 출력 최적화

파일/시트 자동 보호 기능

기존 출력 시트는 자동으로 자재사진통합_001, 002 등으로 백업됨
덮어쓰기 걱정 없이 안전하게 사용 가능

파일명 규칙

이미지 파일명은 자재번호와 동일한 이름이어야 하며 다음 확장자 지원:

.jpg, .jpeg, .png, .bmp, .gif

예)
ABC123.jpg, DEF456.jpeg ...

✅ 매크로 다운로드 또는 복사

코드를 직접 붙여넣고 싶으신 분은 아래 버튼 클릭

Option Explicit

' ====== 사용자 진입점 ======
Public Sub 자재명판_자동생성_좌우레이아웃()
    Const SHT_SRC As String = "자재목록"
    Const SHT_OUT As String = "자재사진통합"

    Dim wsS As Worksheet, wsO As Worksheet
    Dim wsOld As Worksheet, wsNew As Worksheet
    Dim startRow As Range, endRow As Range
    Dim n As Long, blocks As Long
    Dim folderPath As String
    Dim i As Long, idx As Long
    Dim baseRow As Long

    Set wsS = ThisWorkbook.Worksheets(SHT_SRC)

    ' --- 0) 실행 시작: 자재사진통합 시트 복사 → 기존 시트는 일련번호로, 새 시트는 표준명 유지 ---
    On Error Resume Next
    Application.DisplayAlerts = False
    Set wsOld = ThisWorkbook.Worksheets(SHT_OUT)
    On Error GoTo 0

    If Not wsOld Is Nothing Then
        ' (1) 기존 시트 복사 (같은 통합문서 내에 바로 뒤에 복사)
        wsOld.Copy After:=wsOld
        Set wsNew = ActiveSheet        ' 방금 복사된 시트

        ' (2) 기존 시트 이름을 일련번호로 변경
        Dim oldBackupName As String
        oldBackupName = NextSerialName(SHT_OUT & "_")
        wsOld.Name = oldBackupName

        ' (3) 새 시트명을 표준명으로 변경 (충돌 없음: 기존은 이미 백업명으로 변경됨)
        wsNew.Name = SHT_OUT
        Set wsO = wsNew
    Else
        ' 자재사진통합 시트가 없으면 새로 생성 (사용자가 1:9 템플릿을 구성해뒀다고 가정)
        Set wsO = ThisWorkbook.Worksheets.Add
        wsO.Name = SHT_OUT
    End If

    ' (4) 요청사항: 새 시트 10:100000행 모두 지우고, 사진 전부 삭제
    wsO.Rows("10:100000").Clear
    DeletePicturesInRange wsO, wsO.Cells

    ' (5) (기존 코드 유지) 기본 행 높이 보정
    wsO.Rows("10:1000").RowHeight = 10

    ' 1) 범위 입력 (시작/끝 행)
    On Error Resume Next
    wsS.Select
    wsS.Cells.Interior.ColorIndex = 2
    Set startRow = Application.InputBox("자재목록에서 시작 행 번호를 입력하세요 (헤더 제외)", Type:=8)
    If startRow Is Nothing Then Exit Sub
    Set endRow = Application.InputBox("자재목록에서 마지막 행 번호를 입력하세요", Type:=8)
    If startRow Is Nothing Then Exit Sub

    For i = startRow.Row To endRow.Row
        wsS.Cells(i, startRow.Column).Interior.ColorIndex = 34
    Next i

    If endRow.Row < 2 Or endRow.Row < startRow.Row Then
        MsgBox "행 번호가 올바르지 않습니다.", vbExclamation: Exit Sub
    End If

    ' 2) 자재 수량 및 블록(1:9행 템플릿) 수 계산
    n = endRow.Row - startRow.Row + 1
    blocks = (n + 1) \ 2         ' = Ceiling(n/2)

    ' 3) 사진 폴더 선택
    folderPath = 폴더선택()
    If Len(folderPath) = 0 Then
        MsgBox "사진 폴더가 선택되지 않았습니다.", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    On Error GoTo FINALLY

    ' 4) 출력 시트 초기화 (1:9 템플릿은 원본으로 사용하므로, 10행 이하만 남기고 아래 모두 정리)
    ClearBelow wsO, 10
    DeletePicturesInRange wsO, wsO.UsedRange

    ' 5) 블록 복제 (1:9행 → blocks회, 블록 사이 1행 공백)
    Dim b As Long
    For b = 1 To blocks
        If b = 1 Then
            ' 첫 블록은 기존 1:9가 템플릿이므로 그대로 사용
        Else
            baseRow = 1 + (b - 1) * (9 + 1) ' 9행 블록 + 1행 공백
            wsO.Rows("1:9").Copy
            wsO.Rows(baseRow & ":" & baseRow + 8).Insert Shift:=xlDown
            ' 공백 1행 삽입
            wsO.Rows(baseRow + 9).Insert
        End If
    Next b

    ' 6) 행 높이(권장 규격) 통일: 1행 31.5, 2행 210, 3~9행 30 (각 블록마다 적용)
    ApplyRowHeights wsO, blocks

    ' 7) 좌우 레이아웃에 데이터/사진 채우기
     idx = 0
    For i = startRow.Row To endRow.Row
        Dim blk As Long, isLeft As Boolean
        blk = (idx \ 2) + 1
        isLeft = (idx Mod 2 = 0)
        baseRow = 1 + (blk - 1) * (9 + 1)     ' 해당 블록의 시작 행(템플릿의 1행)

        If isLeft Then
            ' ---- Left: 사진 B2:D2, 텍스트 C3:D9 ----
            FillOneRecord _
                wsS, wsO, i, _
                wsO.Range("B2:D2").Offset(baseRow - 1, 0), _
                wsO.Range("C3:D9").Offset(baseRow - 1, 0), _
                folderPath
        Else
            ' ---- Right: 사진 F2:H2, 텍스트 G3:H9 ----
            FillOneRecord _
                wsS, wsO, i, _
                wsO.Range("F2:H2").Offset(baseRow - 1, 0), _
                wsO.Range("G3:H9").Offset(baseRow - 1, 0), _
                folderPath
        End If

        idx = idx + 1
    Next i

    ' === 홀수 개 처리: 마지막 블록의 오른쪽 비우기 ===
    If (n Mod 2 = 1) Then
        Dim lastBlk As Long, lastBase As Long
        lastBlk = blocks
        lastBase = 1 + (lastBlk - 1) * (9 + 1)

        ' 오른쪽 사진/텍스트 영역 비우기

        wsO.Range("G2:H2").Offset(lastBase, 0).Resize(7).ClearContents

'        wsO.Range("G3:H9").Offset(lastBase, 0).ClearContents
'        DeletePicturesInRange wsO, wsO.Range("F2:H2").Offset(lastBase - 1, 0)
    End If


FINALLY:
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

' 존재하지 않는 다음 일련번호 시트명 반환: prefix_001, _002 ... 없으면 타임스탬프
Public Function NextSerialName(ByVal prefix As String) As String
    Dim i As Long, candidate As String
    For i = 1 To 999
        candidate = prefix & Format$(i, "000")
        If Not SheetExists(ThisWorkbook, candidate) Then
            NextSerialName = candidate
            Exit Function
        End If
    Next i
    NextSerialName = prefix & Format(Now, "yyyymmdd_hhnnss")
End Function

' 시트 존재 여부 확인
Public Function SheetExists(ByVal wb As Workbook, ByVal sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(sheetName)
    SheetExists = Not ws Is Nothing
    Set ws = Nothing
    On Error GoTo 0
End Function
' ====== 개별 레코드 쓰기 ======
Private Sub FillOneRecord( _
    ByVal wsS As Worksheet, ByVal wsO As Worksheet, ByVal srcRow As Long, _
    ByVal rngPhoto As Range, ByVal rngDetail As Range, ByVal folderPath As String)

    ' 자재번호로 파일 찾기 (B열)
    Dim partNo As String: partNo = Trim$(CStr(wsS.Cells(srcRow, "B").Value))
    Dim imgPath As String: imgPath = GetImagePathByPartNo(folderPath, partNo)

    ' 사진 지우고 삽입
    DeletePicturesInRange wsO, rngPhoto
    If Len(imgPath) > 0 Then
        PlaceImageFit wsO, rngPhoto, imgPath
    Else
        With rngPhoto
            .Value = "사진 없음"
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Size = 14
            .Font.Bold = True
        End With
    End If

    ' 상세 텍스트 쓰기 (C3:D9 또는 G3:H9) ? 병합셀 대응
    ' 순서: SAP No, 자재 번호, 품명, 규격, 설비 종류, Conv' Type, Rack No
    Dim vals(1 To 7) As Variant
    vals(1) = wsS.Cells(srcRow, "A").Value
    vals(2) = wsS.Cells(srcRow, "B").Value
    vals(3) = wsS.Cells(srcRow, "C").Value
    vals(4) = wsS.Cells(srcRow, "D").Value
    vals(5) = wsS.Cells(srcRow, "E").Value
    vals(6) = wsS.Cells(srcRow, "F").Value
    vals(7) = wsS.Cells(srcRow, "G").Value

    Dim r As Long
    For r = 1 To 7
        With rngDetail.Rows(r)
            .Value = vals(r)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
    Next r
End Sub

' ====== 이미지 경로 찾기 (.jpg/.jpeg/.png/.bmp/.gif) ======
Private Function GetImagePathByPartNo(ByVal folderPath As String, ByVal partNo As String) As String
    Dim ext As Variant, p As String
    Dim exts As Variant: exts = Array("*.jpg", "*.jpeg", "*.png", "*.bmp", "*.gif")
    Dim f As String

    If Right$(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    For Each ext In exts
        f = Dir$(folderPath & partNo & "." & Replace(ext, "*.", ""))
        If Len(f) > 0 Then
            GetImagePathByPartNo = folderPath & f
            Exit Function
        End If
        ' 확장자 대소문자 섞여 있는 경우를 대비한 와일드카드 탐색
        f = Dir$(folderPath & partNo & "*")
        If Len(f) > 0 Then
            p = LCase$(f)
            If Right$(p, 4) = ".jpg" Or Right$(p, 5) = ".jpeg" Or Right$(p, 4) = ".png" _
               Or Right$(p, 4) = ".bmp" Or Right$(p, 4) = ".gif" Then
                GetImagePathByPartNo = folderPath & f
                Exit Function
            End If
        End If
    Next ext
End Function

' 병합셀 전체(MergeArea)의 좌표를 이용해 "가득 채우기" 배치
' 병합셀 내부에 "가득 채우되" 종횡비를 고정하지 않고(contain 아님),
' 좌우·상하 여백이 각각 동일하도록 중앙 정렬하는 버전
Private Sub PlaceImageFit(ByVal ws As Worksheet, ByVal tgt As Range, ByVal imgPath As String, Optional ByVal inset As Double = 4)
    Dim area As Range
    Dim L As Double, T As Double, W As Double, H As Double
    Dim Wi As Double, Hi As Double
    Dim shp As Shape

    ' 병합 범위 전체 박스
    Set area = tgt.MergeArea
    L = area.Left: T = area.Top: W = area.Width: H = area.Height

    ' 내부 박스(여백 적용)
    Wi = Application.Max(1, W - 2 * inset)
    Hi = Application.Max(1, H - 2 * inset)

    ' 그림 삽입 → 내부 박스 크기로 강제 맞춤
    Set shp = ws.Shapes.AddPicture( _
        Filename:=imgPath, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=L + inset, Top:=T + inset, Width:=Wi, Height:=Hi)

    With shp
        ' 종횡비 고정 해제: 내부 박스에 정확히 맞춰 왜곡 허용
        .LockAspectRatio = msoFalse
        .Width = Wi + 2
        .Height = Hi + 2

        ' 좌우·상하 여백 균등(중앙 정렬)
        .Left = L + (W - .Width) / 2 + 0.5
        .Top = T + (H - .Height) / 2 + 0.5

        ' 셀 이동/크기 변경에 따라가도록
        .Placement = xlMoveAndSize
    End With
End Sub

' ====== 폴더 선택 ======
Private Function 폴더선택() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .title = "사진 폴더를 선택하세요 (자재번호.확장자)"
        .AllowMultiSelect = False
        If .Show = -1 Then
            폴더선택 = .SelectedItems(1)
        Else
            폴더선택 = ""
        End If
    End With
End Function

' ====== 특정 범위 내 그림 삭제 ======
Private Sub DeletePicturesInRange(ByVal ws As Worksheet, ByVal rng As Range)
    Dim shp As Shape
    For Each shp In ws.Shapes
        If shp.Type = msoPicture Then
            If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then shp.Delete
        End If
    Next shp
End Sub

' ====== 출력 시트 아래쪽 정리 ======
Private Sub ClearBelow(ByVal ws As Worksheet, ByVal keepUpToRow As Long)
    Dim lastR As Long
    lastR = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastR > keepUpToRow Then
        ws.Rows(keepUpToRow + 1 & ":" & ws.Rows.Count).Clear
    End If
End Sub

' ====== 블록별 행 높이 일괄 적용 ======
Private Sub ApplyRowHeights(ByVal ws As Worksheet, ByVal blocks As Long)
    Dim b As Long, baseRow As Long
    For b = 1 To blocks
        baseRow = 1 + (b - 1) * (9 + 1)
        ws.Rows(baseRow + 0).RowHeight = 31.5  ' 1행
        ws.Rows(baseRow + 1).RowHeight = 210   ' 2행(사진)
        ws.Rows(baseRow + 2 & ":" & baseRow + 8).RowHeight = 30  ' 3~9행
    Next b
End Sub

자재사진통합_v7.xlsm

0.98MB

폴더내 하부폴더 포함 모든 엑셀파일 문서 내용에서 검색어 한꺼번에 찾는 법!

노만e — Tue, 23 Sep 2025 22:33:55 +0900

오늘 일일 업무일지 수년치를 열어, 원하는 검색어를 찾다가, 내가 도대체 왜 이러고 있나 한숨이...났습니다.

저희는 4개팀, 3개조로 1년 365일 쉬지 않고 일합니다. 일일 업무일지는 4개팀이 주간, 야간 작성하니,

하루에만 8개의 일지가 생성 됩니다. 그걸 365일X2년이면.. 5840개!!! 허걱~~

수십 개, 수백 개의 엑셀 파일을 하나씩 열어가며 데이터를 찾고 계신가요?
이제는 폴더 전체 엑셀 파일을 자동으로 검색해주는 VBA 매크로로 단번에 해결하세요!

✅ 이런 분들에게 강력 추천합니다

✔️ 수많은 견적서/매출자료/보고서에서 특정 값을 찾아야 하는 분
✔️ 부서별/연도별로 정리된 엑셀 파일을 검색해야 하는 실무자
✔️ 수기로 작업하는 비효율적인 검색 방식에서 벗어나고 싶은 분
✔️ 폴더 내 모든 엑셀 파일을 자동 검색하고, 결과를 정리하고 싶은 분

주요 기능 (엑셀 VBA 자동 검색기)

기능설명

폴더 선택	원하는 폴더를 지정하면 하위 폴더까지 검색
키워드 다중 검색	최대 5개의 키워드를 동시에 검색 가능 (B3~B7 입력)
검색 결과 정리	[검색결과] 시트에 자동 기록
맥락 확인	앞/뒤 셀 내용, 시트명, 셀주소까지 제공
현재 파일은 제외	실행 중인 매크로 파일은 자동으로 제외 처리

사용 방법

① VBA 코드 삽입

엑셀에서 Alt + F11 키를 눌러 VBA 편집기 실행
삽입 > 모듈 클릭
아래 전체 코드를 붙여넣기
저장 (.xlsm 형식으로 저장 권장)

✅ 전체 코드는 이 글 하단에 제공됩니다!

② 키워드 입력

현재 엑셀 파일의 아무 시트나 선택 후
B3:B7 셀에 찾고 싶은 키워드를 입력하세요
예) 고객명, 제품명, 날짜 등

③ 매크로 실행

Alt + F8 → SearchInExcelFiles 선택 → 실행
검색할 폴더를 선택하면 자동으로 모든 엑셀을 열어 검색 진행
결과는 [검색결과] 시트에 자동 정리됩니다!

검색 결과 예시

파일명시트명찾은값이전셀이후셀셀주소

sales_2023	매출	홍길동	서울점	1,000,000	C12
invoice_005	거래내역	2023-08-21	제품명	결제완료	B7

실무에서 이렇게 활용했어요

“한 달치 고객 요청사항이 어디 있었는지 몰라서 검색했는데 5초만에 찾았습니다.”
“수백 개 엑셀을 수작업으로 보던 시절은 끝났어요.”
“모든 키워드가 한눈에 정리돼서 보고서 만들기도 쉬워졌어요.”

지금 바로 사용해보세요!

아래 코드 복사해서 엑셀 VBA에 붙여넣기만 하면 끝!
엑셀을 자주 다루는 분이라면 100% 실무에 도움됩니다.

전체 VBA 코드 (복사해서 붙여넣기)

Sub SearchInExcelFiles()
    Dim folderPath As String
    Dim currentWs As Worksheet
    Dim resultWs As Worksheet
    Dim searchValues As Variant
    Dim resultRow As Long
    Dim fileCount As Long
    Dim searchCount As Long

    On Error GoTo ErrorHandler

    ' 현재 시트 설정
    Set currentWs = ActiveSheet

    ' 폴더 선택 대화상자
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "검색할 폴더를 선택하세요"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            MsgBox "폴더가 선택되지 않았습니다."
            Exit Sub
        End If
    End With

    ' A2:A6 값을 배열로 저장
    On Error Resume Next
    searchValues = currentWs.Range("B3:B7").Value
    On Error GoTo ErrorHandler

    ' 검색값이 있는지 확인
    searchCount = 0
    For i = 1 To UBound(searchValues, 1)
        If Trim(CStr(searchValues(i, 1))) <> "" Then
            searchCount = searchCount + 1
        End If
    Next i

    If searchCount = 0 Then
        MsgBox "A2:A6에 검색할 값이 없습니다."
        Exit Sub
    End If

    ' [검색결과] 시트 생성 또는 가져오기
    Set resultWs = CreateOrGetResultSheet()

    ' 결과 시트 헤더 설정
    With resultWs
        .Cells(1, 1).Value = "파일명"
        .Cells(1, 2).Value = "시트명"
        .Cells(1, 3).Value = "찾은값"
        .Cells(1, 4).Value = "이전셀"
        .Cells(1, 5).Value = "이후셀"
        .Cells(1, 6).Value = "셀위치"

        ' 헤더 서식 설정
        .Range("A1:F1").Font.Bold = True
        .Range("A1:F1").Interior.Color = RGB(200, 200, 200)

        ' 기존 데이터 삭제
        .Range("A2:F10000").Clear
    End With

    ' 결과 출력 시작 행
    resultRow = 2
    fileCount = 0

    ' 화면 업데이트 중지 (성능 향상)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' 상태 표시
    Application.StatusBar = "검색 중..."

    ' 폴더 내 모든 엑셀 파일 검색
    Call SearchFolder(folderPath, searchValues, resultWs, resultRow, fileCount)

    ' 결과 시트 활성화 및 열 너비 자동 조정
    resultWs.Activate
    resultWs.Columns("A:F").AutoFit

    GoTo CleanUp

ErrorHandler:
    MsgBox "오류가 발생했습니다: " & Err.Description & " (오류 번호: " & Err.Number & ")"

CleanUp:
    ' 설정 복원
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False

    If Err.Number = 0 Then
        Dim foundCount As Long
        foundCount = resultRow - 2
        MsgBox "검색이 완료되었습니다!" & vbCrLf & _
               "처리된 파일 수: " & fileCount & vbCrLf & _
               "검색된 결과 수: " & foundCount & vbCrLf & _
               "[검색결과] 시트를 확인해주세요."
    End If
End Sub

Function CreateOrGetResultSheet() As Worksheet
    Dim ws As Worksheet
    Dim sheetExists As Boolean

    ' [검색결과] 시트가 이미 있는지 확인
    sheetExists = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = "검색결과" Then
            Set CreateOrGetResultSheet = ws
            sheetExists = True
            Exit For
        End If
    Next ws

    ' 시트가 없으면 새로 생성
    If Not sheetExists Then
        Set CreateOrGetResultSheet = ThisWorkbook.Worksheets.Add
        CreateOrGetResultSheet.Name = "검색결과"
    End If
End Function

Sub SearchFolder(folderPath As String, searchValues As Variant, resultWs As Worksheet, ByRef resultRow As Long, ByRef fileCount As Long)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim subFolder As Object

    ' FileSystemObject 생성
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    Set folder = fso.GetFolder(folderPath)
    On Error GoTo 0

    If folder Is Nothing Then
        Exit Sub
    End If

    ' 현재 폴더의 엑셀 파일 검색
    For Each file In folder.Files
        If IsExcelFile(file.Name) Then
            fileCount = fileCount + 1
            Application.StatusBar = "검색 중... 파일: " & file.Name
            Call SearchInFile(file.Path, searchValues, resultWs, resultRow)
        End If
    Next file

    ' 하위 폴더 재귀 검색
    For Each subFolder In folder.SubFolders
        On Error Resume Next
        Call SearchFolder(subFolder.Path, searchValues, resultWs, resultRow, fileCount)
        On Error GoTo 0
    Next subFolder
End Sub

Function IsExcelFile(fileName As String) As Boolean
    Dim ext As String
    ext = LCase(Right(fileName, 4))
    IsExcelFile = (ext = ".xls" Or Right(LCase(fileName), 5) = ".xlsx" Or Right(LCase(fileName), 5) = ".xlsm")
End Function

Sub SearchInFile(filePath As String, searchValues As Variant, resultWs As Worksheet, ByRef resultRow As Long)
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim searchRange As Range
    Dim foundCell As Range
    Dim firstAddress As String
    Dim i As Integer
    Dim searchValue As String
    Dim fileOpened As Boolean
    Dim fileName As String
    Dim fso As Object

    ' 변수 초기화
    Set wb = Nothing
    fileOpened = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error GoTo ErrorHandler

    ' 현재 파일인지 확인 (현재 파일은 건너뜀)
    If filePath = ThisWorkbook.FullName Then
        Exit Sub
    End If

    ' 파일명 추출 (확장자 제외)
    fileName = fso.GetBaseName(filePath)

    ' 엑셀 파일 열기 시도
    Set wb = Workbooks.Open(filePath, ReadOnly:=True, UpdateLinks:=0, Password:="")
    fileOpened = True

    ' 각 검색 값에 대해
    For i = 1 To UBound(searchValues, 1)
        searchValue = Trim(CStr(searchValues(i, 1)))

        ' 빈 값은 건너뜀
        If searchValue = "" Then
            GoTo NextSearchValue
        End If

        ' 워크북의 모든 시트에서 검색
        For Each ws In wb.Worksheets
            On Error GoTo NextSheet

            ' 시트가 보호되어 있거나 숨겨져 있어도 검색 시도
            If ws.Visible = xlSheetVisible Or ws.Visible = xlSheetHidden Then
                Set searchRange = ws.UsedRange

                If Not searchRange Is Nothing Then
                    ' 다양한 검색 방법으로 시도

                    ' 1. 정확히 일치하는 값 검색
                    Set foundCell = searchRange.Find(What:=searchValue, _
                                                    LookIn:=xlValues, _
                                                    LookAt:=xlWhole, _
                                                    SearchOrder:=xlByRows, _
                                                    SearchDirection:=xlNext, _
                                                    MatchCase:=False)

                    ' 2. 정확히 일치하지 않으면 부분 일치 검색
                    If foundCell Is Nothing Then
                        Set foundCell = searchRange.Find(What:=searchValue, _
                                                        LookIn:=xlValues, _
                                                        LookAt:=xlPart, _
                                                        SearchOrder:=xlByRows, _
                                                        SearchDirection:=xlNext, _
                                                        MatchCase:=False)
                    End If

                    ' 3. 수식에서 검색
                    If foundCell Is Nothing Then
                        Set foundCell = searchRange.Find(What:=searchValue, _
                                                        LookIn:=xlFormulas, _
                                                        LookAt:=xlWhole, _
                                                        SearchOrder:=xlByRows, _
                                                        SearchDirection:=xlNext, _
                                                        MatchCase:=False)
                    End If

                    ' 찾은 값이 있으면 모든 일치하는 셀을 찾기
                    If Not foundCell Is Nothing Then
                        firstAddress = foundCell.Address

                        Do
                            ' 검색결과 시트에 결과 기록
                            resultWs.Cells(resultRow, 1).Value = fileName           ' A열: 파일명
                            resultWs.Cells(resultRow, 2).Value = ws.Name            ' B열: 시트명
                            resultWs.Cells(resultRow, 3).Value = foundCell.Value    ' C열: 찾은값
                            resultWs.Cells(resultRow, 6).Value = foundCell.Address  ' F열: 셀위치

                            ' 찾은 값의 이전셀 (D열에 기록)
                            If foundCell.Column > 1 Then
                                On Error Resume Next
                                resultWs.Cells(resultRow, 4).Value = foundCell.Offset(0, -1).Value
                                On Error GoTo NextCell
                            End If

                            ' 찾은 값의 이후셀 (E열에 기록)
                            If foundCell.Column < ws.Columns.Count Then
                                On Error Resume Next
                                resultWs.Cells(resultRow, 5).Value = foundCell.Offset(0, 1).Value
                                On Error GoTo NextCell
                            End If

NextCell:
                            resultRow = resultRow + 1

                            ' 다음 일치하는 셀 찾기
                            On Error Resume Next
                            Set foundCell = searchRange.FindNext(foundCell)
                            On Error GoTo NextSheet

                            ' 처음 찾은 셀로 돌아왔거나 없으면 루프 종료
                            If foundCell Is Nothing Then Exit Do
                            If foundCell.Address = firstAddress Then Exit Do

                        Loop
                    End If
                End If
            End If

NextSheet:
            On Error GoTo ErrorHandler
        Next ws

NextSearchValue:
    Next i

    ' 정상적으로 파일 닫기
    If fileOpened And Not wb Is Nothing Then
        wb.Close SaveChanges:=False
        Set wb = Nothing
    End If
    Exit Sub

ErrorHandler:
    ' 오류 발생 시 안전하게 파일 닫기
    On Error Resume Next
    If fileOpened And Not wb Is Nothing Then
        wb.Close SaveChanges:=False
        Set wb = Nothing
    End If
    On Error GoTo 0
End Sub

✅ 마무리: 클릭 한 번으로 엑셀 검색 끝내기

이제는 반복적인 검색 작업에서 벗어나세요.
엑셀 자동 검색 매크로, 실무에서 지금 바로 활용해보세요.

궁금한 점은 댓글로 질문 주세요!
좋아요 ❤️ + 이웃추가 는 큰 힘이 됩니다!

폴더내 모든 엑셀파일에서 검색값 찾기.xlsm

예제파일.zip

엑셀 자동 단어 암기 “깜빡이 학습기 v2” | DAY 선택, 시트 선택, 모드 설정까지!

노만e — Thu, 18 Sep 2025 22:47:09 +0900

엑셀 깜박이 학습기

“단어 외우는 게 너무 지루해요…”
“엑셀로 자동 깜빡이처럼 단어 학습할 수 없을까?”

단어 외우기, 무조건 반복만이 답일까요?
이제 엑셀 VBA 깜빡이 학습기로 시간은 아끼고 암기 효율은 올려보세요!

이 글에서는 2025년 최신버전인
✅ “DAY 선택 + 시트 선택 + 뜻 ↔ 단어 모드 + 시간 간격 조절”
기능까지 탑재된 엑셀 자동 깜빡이 학습기 v2를 소개합니다.

✨ 깜빡이 학습기 v2의 주요 기능

기능 항목설명

✅ 시트 선택	여러 단어장 시트 중 원하는 시트를 선택해 학습
✅ DAY 선택	"DAY 1 ~ DAY 31" 중 필요한 DAY만 학습 가능
✅ 모드 전환	"단어 → 뜻" 또는 "뜻 → 단어" 방향 선택
✅ 시간 간격 조절	1초, 2초, 3초 등 사용자 지정 가능
✅ 자동 반복	단어/뜻을 자동으로 교체하며 표시
✅ 일시정지 / 재시작 / 중지	학습 흐름을 자유롭게 제어 가능

이 모든 기능을 드롭다운 메뉴에서 클릭 한 번으로 설정할 수 있어, 엑셀 초보자도 쉽게 사용할 수 있습니다!

어떻게 사용하나요?

① 시트 구성

[사전] 시트 예시:

A열 (DAY)B열 (단어)C열 (뜻)

DAY 1	apple	사과
DAY 1	banana	바나나
DAY 2	lion	사자

[깜빡이] 시트에서 매크로 실행

② 셋업 및 실행 순서

Alt + F11로 VBA 편집기 열기
위 코드를 새 모듈에 붙여넣기
SetupFlashBoard 실행 (초기 셋업)
StartFlashCards 실행 (학습 시작)

설정 항목 설명

셀 위치기능예시

L10	시트명 선택	중등영단어, 수능영단어 등
L11	DAY 선택	DAY 1 ~ DAY 31
L12	깜빡 간격	1초, 2초 등 입력 가능
L13	모드	단어 → 뜻 / 뜻 → 단어

TIP: "단어 → 뜻"은 영어단어 → 해석 순서,
"뜻 → 단어"는 해석 → 영어단어 순서로 표시됩니다.

학습 모드 활용 팁

처음 외울 땐: 단어 → 뜻으로 빠르게 훑기
시험 전 점검 땐: 뜻 → 단어로 역방향 테스트
DAY별로 나눠서 하루치 학습 분량만 집중 공략

원하는 시트와 DAY만 선택해서 효율적으로 복습하세요!

일시정지 & 중지 방법

PauseResumeFlashCards: 학습 일시정지 / 재개
StopFlashCards: 학습 종료 후 초기화

지금 바로 사용해보세요!

엑셀만 있으면 무료로, 간단한 설정만으로
디지털 암기학습 도구를 완성할 수 있습니다!

단어 학습, 무작정 외우지 말고
자동으로 깜빡이며 뇌에 각인시키세요!

템플릿 다운로드

깜빡이 학습기_ver2.0.xlsm

0.10MB

블로그 구독하고 더 많은 엑셀 학습 도구 받아가세요!

더 많은 엑셀 자동화 / 학습 매크로 / VBA 꿀팁을 받아보고 싶다면?
블로그 구독 버튼을 눌러주세요!

엑셀로 자동 단어 암기! "깜빡이 학습기" 매크로로 집중력 UP

노만e — Wed, 17 Sep 2025 23:49:59 +0900

영어 단어 암기, 자격증 필기 공부, 아이 학습지 반복학습
매번 수동으로 보고 외우기 지치셨나요?

지금부터 소개할 이 "엑셀 깜빡이 학습기" 매크로는,
단어와 뜻을 자동으로 1초 간격으로 번갈아 보여주는 학습 도우미입니다.

엑셀만 있으면 무료!
클릭 한 번이면 자동 학습 시작!

이런 분들께 추천합니다

영어, 한자, 일본어, 중국어 등 외국어 단어를 외우는 분
초등학생 자녀의 반복 학습을 돕고 싶은 학부모
시험 대비 요약 암기가 필요한 수험생
기존 학습 방식에 지루함을 느끼는 모든 학습자

기능 요약

기능설명

자동 반복	단어 → 뜻 → 다음 단어를 1초 간격으로 자동 반복
큰 글씨 강조	글씨 크기 72pt, 중앙 정렬, 색상 강조(파랑/빨강)
간단한 구조	A열: 단어, B열: 뜻만 입력하면 OK
⏸ 일시정지 / 재시작	중간에 멈추거나 다시 시작 가능
⛔ 중단 버튼	원할 때 즉시 학습 종료

사용 방법

엑셀 실행 후 ‘사전’ 시트 생성
아래와 같이 단어/뜻 입력

| 단어 | 뜻 | |--------------|-------------| | apple | 사과 | | elephant | 코끼리 |

Alt + F11 → VBA 모듈에 코드 붙여넣기
Alt + F8 → StartFlashCards 실행
‘깜빡이’ 시트에서 자동 암기 시작!

1초 간격으로 단어 → 뜻 → 다음 단어가 깜빡이며 표시됩니다.

Option Explicit

' ===== 모듈 전역 변수 =====
Dim currentRow As Long
Dim maxRow As Long
Dim showingWord As Boolean
Dim isRunning As Boolean
Dim nextTime As Date   ' OnTime 예약/해제용

' ===== 시트 보드(레이아웃) 1회 설정 =====
Public Sub SetupFlashBoard()
    Dim ws As Worksheet
    Set ws = EnsureSheet("깜빡이")

    With ws
        ' A1:I16 전체 초기화
        .Range("A1:I16").Clear
        ' 혹시 병합되어 있다면 전부 해제
        .Range("A1:I16").UnMerge

        ' 열너비 A:I = 13
        .Columns("A:I").ColumnWidth = 13
        ' 행높이 1:16 = 25
        .Rows("1:16").RowHeight = 25

        ' A1:I16 병합 + 기본 서식
        With .Range("A1:I16")
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Size = 72
            .Font.Bold = True
            .Value = ""

            ' 테두리 초기화 후 외곽 굵은 녹색
            .Borders.LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .Color = RGB(0, 176, 80)
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .Color = RGB(0, 176, 80)
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .Color = RGB(0, 176, 80)
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .Color = RGB(0, 176, 80)
            End With
        End With
    End With
End Sub

' ===== 메인 실행 =====
Public Sub StartFlashCards()
    Dim wsDict As Worksheet
    Dim wsMain As Worksheet

    Set wsDict = EnsureSheet("사전")
    Set wsMain = EnsureSheet("깜빡이")

    ' 레이아웃을 항상 보장
    SetupFlashBoard

    ' 사전 시트 마지막 행(A열 기준)
    With wsDict
        maxRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    If maxRow < 1 Or Len(wsDict.Range("A1").Value) = 0 Then
        MsgBox "사전 시트에 단어 데이터가 없습니다.", vbExclamation
        Exit Sub
    End If

    currentRow = 2
    showingWord = True
    isRunning = True

    ShowCurrentContent

    nextTime = Now + TimeValue("00:00:01")
    Application.OnTime earliesttime:=nextTime, procedure:="ShowNext"
End Sub

' ===== 현재 내용 표시 =====
Private Sub ShowCurrentContent()
    Dim content As String

    With Worksheets("사전")
        If showingWord Then
            content = .Cells(currentRow, 1).Value    ' A열: 단어
        Else
            content = .Cells(currentRow, 2).Value    ' B열: 뜻
        End If
    End With

    With Worksheets("깜빡이").Range("A1:I16")
        .Value = content
        .Font.Size = 72
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter

        If showingWord Then
            .Font.Color = RGB(0, 0, 255)            ' 파랑(단어)
        Else
            .Font.Color = RGB(255, 0, 0)            ' 빨강(뜻)
        End If
    End With
End Sub

' ===== 다음 내용 표시 =====
Public Sub ShowNext()
    If Not isRunning Then Exit Sub

    If showingWord Then
        showingWord = False             ' 단어 → 뜻
    Else
        showingWord = True              ' 뜻 → 다음 단어
        currentRow = currentRow + 1
        If currentRow > maxRow Then currentRow = 1
    End If

    ShowCurrentContent

    nextTime = Now + TimeValue("00:00:01")
    Application.OnTime earliesttime:=nextTime, procedure:="ShowNext"
End Sub

' ===== 중지 =====
Public Sub StopFlashCards()
    isRunning = False
    On Error Resume Next
    If nextTime <> 0 Then
        Application.OnTime earliesttime:=nextTime, procedure:="ShowNext", schedule:=False
    End If
    On Error GoTo 0

    With EnsureSheet("깜빡이").Range("A1:I16")
        .Value = ""
    End With

    MsgBox "단어 학습을 종료했습니다."
End Sub

' ===== 일시정지 / 재시작 =====
Public Sub PauseResumeFlashCards()
    If isRunning Then
        isRunning = False
        On Error Resume Next
        If nextTime <> 0 Then
            Application.OnTime earliesttime:=nextTime, procedure:="ShowNext", schedule:=False
        End If
        On Error GoTo 0
        MsgBox "일시정지되었습니다."
    Else
        isRunning = True
        nextTime = Now + TimeValue("00:00:01")
        Application.OnTime earliesttime:=nextTime, procedure:="ShowNext"
        MsgBox "재시작되었습니다."
    End If
End Sub

' ===== 유틸: 시트 보장 =====
Private Function EnsureSheet(ByVal shtName As String) As Worksheet
    On Error Resume Next
    Set EnsureSheet = ThisWorkbook.Worksheets(shtName)
    On Error GoTo 0
    If EnsureSheet Is Nothing Then
        Set EnsureSheet = ThisWorkbook.Worksheets.Add
        EnsureSheet.Name = shtName
    End If
End Function

학습 효과

✅ 시각적 자극으로 집중력 강화
✅ 반복 노출로 암기 효과 극대화
✅ 무의식 반복 학습으로 장기 기억 정착

특히 어린이, 청소년, ADHD 아이들 학습에 효과적입니다!

자주 묻는 질문(FAQ)

❓ 엑셀 버전이 어떻게 되나요?

⤷ Microsoft Excel 2010 이상이면 작동합니다 (Win 가능)

❓ 간격을 1초 말고 3초로 바꾸고 싶어요

⤷ TimeValue("00:00:01") 부분을 TimeValue("00:00:03")로 수정하세요.

❓ 무작위(Random)로 단어가 나오게 하고 싶어요

⤷ 가능합니다! 댓글로 요청 주시면 코드 추가해드립니다

템플릿 다운로드 (무료)

✨ 아래 버튼을 눌러 템플릿 파일을 받아가세요!

깜빡이 학습기.xlsm

폴더내 모든 파일 및 시트의 셀값 변경.xlsm

더 똑똑하게 공부하고 싶다면?

이 자동 깜빡이 학습기는 단순한 매크로 이상의 집중력 유도 도구입니다.
반복적인 입력이나 인쇄 없이, 디지털 학습으로 완전 전환해보세요!

지금 바로 시작하세요!

영어단어, 자격증 필기, 외국어 공부
아이들의 학습지 대체 도구

엑셀 하나로, 자동으로, 집중해서 외우는 방법!

지금 바로 다운로드 받고 실행해보세요.
당신의 암기 학습 방식이 완전히 달라질 거예요!

엑셀 VBA로 여러 파일, 전체 시트 셀 값 한 번에 '찾아바꾸기' 하는 방법

노만e — Mon, 15 Sep 2025 22:19:47 +0900

회사에서 반복적인 엑셀 작업, 힘드시죠?
여러 개의 엑셀 파일에 들어있는 특정 단어를 한 번에 찾아 바꿀 수 있다면 얼마나 편리할까요?

오늘은 "VBA(엑셀 매크로)"를 활용해 폴더 안의 모든 엑셀 파일을 자동으로 수정하는 방법을 소개합니다.
파일을 하나씩 열지 않고, 자동으로 처리하는 방법이 궁금하신 분들께 꼭 도움이 될 내용이에요.

❓ 왜 이 작업이 필요할까요?

예시 상황
✅ 고객사명이 바뀌었어요 → 모든 문서에서 "A회사" → "B회사"로
✅ 연도가 바뀌었어요 → "2023년" → "2024년"으로
✅ 담당자가 변경됐어요 → "김영희" → "박민수"로
✅ 링크가 변경됐어요 → 옛날 URL을 최신 URL로 업데이트하고 싶어요

수십 개 파일을 열어서 하나하나 바꾸는 건 비효율적이죠.
이럴 때는, 한 번의 클릭으로 끝내는 엑셀 VBA 자동화가 정답입니다!

VBA 매크로 코드 소개

폴더 안의 모든 엑셀 파일을 열고

지정한 문자열을 찾아

새 문자열로 변경한 뒤

저장하고 닫기까지 자동 수행됩니다.

사용할 매크로 코드는 아래와 같아요:

Sub ReplaceCellContents()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim currentWb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim oldValue As String
    Dim newValue As String
    Dim lastRow As Long
    Dim j As Integer
    Dim replaceCount As Long
    Dim totalReplaceCount As Long

    ' 현재 워크북 참조
    Set currentWb = ThisWorkbook

    ' 폴더 선택 대화상자
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "파일이 있는 폴더를 선택하세요"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "폴더가 선택되지 않았습니다."
            Exit Sub
        End If
        folderPath = .SelectedItems(1)
    End With

    ' 폴더 경로 끝에 백슬래시 추가 (없는 경우)
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If

    ' A열과 B열에서 변경 정보 읽기 (현재 워크북의 활성 시트에서)
    With currentWb.ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lastRow < 1 Then
            MsgBox "변경할 내용 목록이 없습니다."
            Exit Sub
        End If
    End With

    ' 화면 업데이트 및 경고 비활성화
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    totalReplaceCount = 0

    ' 폴더 내의 모든 Excel 파일 처리
    fileName = Dir(folderPath & "*.xls*")

    Do While fileName <> ""
        ' 현재 매크로가 실행되는 파일은 제외
        If fileName <> currentWb.name Then
            On Error GoTo ErrorHandler

            ' 파일 열기
            Set wb = Workbooks.Open(folderPath & fileName)

            ' 1번째 시트부터 모든 시트에 대해 처리
            For i = 1 To wb.Worksheets.Count
                Set ws = wb.Worksheets(i)

                ' A열과 B열의 모든 행을 확인하여 내용 변경
                For j = 2 To lastRow
                    oldValue = Trim(CStr(currentWb.ActiveSheet.Cells(j, 1).Value))
                    newValue = Trim(CStr(currentWb.ActiveSheet.Cells(j, 2).Value))

                    ' 빈 값이 아닌 경우 찾아바꾸기 실행
                    If oldValue <> "" And newValue <> "" Then
                        ' 현재 시트에서 찾아바꾸기
                        ws.Cells.Replace What:=oldValue, _
                                        Replacement:=newValue, _
                                        LookAt:=xlPart, _
                                        SearchOrder:=xlByRows, _
                                        MatchCase:=False, _
                                        SearchFormat:=False, _
                                        ReplaceFormat:=False
                    End If
                Next j
            Next i

            ' 파일 저장 및 닫기
            wb.Save
            wb.Close False

        End If

        ' 다음 파일로
        fileName = Dir()
    Loop

    ' 화면 업데이트 및 경고 다시 활성화
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "셀 내용 변경이 완료되었습니다."
    Exit Sub

ErrorHandler:
    ' 오류 발생 시 처리
    If Not wb Is Nothing Then
        wb.Close False
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "파일 처리 중 오류가 발생했습니다: " & fileName & vbCrLf & Err.Description
    Resume Next
End Sub

사용 방법

A열에 찾을 내용, B열에 바꿀 내용을 작성
매크로 실행 (Alt + F8 > ReplaceCellContents 실행)
폴더 선택 > 자동 실행

✔ 매크로가 적용되지 않게 하고 싶은 파일은 다른 폴더로 옮겨주세요!
✔ 본인 매크로 파일은 자동으로 제외됩니다.

✅ 마무리 요약

폴더 내 엑셀 파일 일괄 수정 매크로
"찾기 → 바꾸기"를 자동화
하이퍼링크 변경도 가능
업무 자동화, 시간 절약에 강력 추천!

블로그 구독하고 더 많은 VBA 꿀팁 받아보세요!

이처럼 업무 자동화, 문서 최적화에 도움이 되는
엑셀 VBA 매크로 활용법을 계속해서 공유하고 있습니다.
블로그 이웃 추가 + 알림 설정 하셔서
유용한 실전 자동화 예제를 꾸준히 받아보세요!

시트내 셀 값 변경_파일리스트.zip

0.09MB

엑셀에서 진짜 ‘아날로그 시계’를 만드는 방법 (VBA 시계 만들기)

노만e — Sat, 13 Sep 2025 15:58:46 +0900

엑셀로 시계를 만든다?
놀랍지만 실제로 작동하는 아날로그 시계가 가능합니다!
오늘은 VBA(매크로)를 활용해, 엑셀 워크시트 위에 실시간으로 움직이는 시계를 구현하는 방법을 소개할게요.

어떤 시계인가요?

이 매크로는 엑셀 시트에 다음과 같은 시계를 만들어줍니다:

12시 방향 숫자와 눈금이 있는 원형 시계
⏰ 시침/분침/초침이 실시간으로 갱신
매 1초마다 자동 업데이트 (Application.OnTime 사용)
⚙ 필요 시 시계 정지 버튼도 제공 (StopClock)

핵심 구성요소

구성요소설명

DrawClockFace	시계 외곽, 숫자, 눈금, 중심 점 생성
UpdateClock	현재 시간을 읽어 바늘 각도 계산 후 그리기
StartClock	시계 시작 (초기화 및 타이머 등록)
StopClock	시계 중지 (타이머 해제)

VBA 코드

Option Explicit

' ===== 설정값 =====
Private nextTime As Date
Private Const SHT As String = "Clock"
Private Const CX As Single = 200    ' 중심 X
Private Const CY As Single = 200    ' 중심 Y
Private Const R  As Single = 150    ' 반지름
Private Const PI As Double = 3.14159265358979

' ===== 공개 진입점 =====
Public Sub StartClock()
    Dim ws As Worksheet: Set ws = EnsureSheet(SHT)
    DrawClockFace ws
    UpdateClock
End Sub

Public Sub StopClock()
    On Error Resume Next
    Application.OnTime earliesttime:=nextTime, procedure:="UpdateClock", schedule:=False
    On Error GoTo 0
End Sub

' ===== 유틸 =====
Private Function EnsureSheet(ByVal name As String) As Worksheet
    On Error Resume Next
    Set EnsureSheet = ThisWorkbook.Worksheets(name)
    On Error GoTo 0
    If EnsureSheet Is Nothing Then
        Set EnsureSheet = ThisWorkbook.Worksheets.Add
        EnsureSheet.name = name
    End If
End Function

Private Sub DeleteByPrefix(ws As Worksheet, ByVal prefix As String)
    Dim i As Long
    For i = ws.Shapes.Count To 1 Step -1
        If Left$(ws.Shapes(i).name, Len(prefix)) = prefix Then
            ws.Shapes(i).Delete
        End If
    Next i
End Sub

Private Sub DeleteIfExists(ws As Worksheet, ByVal nm As String)
    On Error Resume Next
    ws.Shapes(nm).Delete
    On Error GoTo 0
End Sub

' ===== 시계판 그리기 =====
Private Sub DrawClockFace(ws As Worksheet)
    Dim i As Long, ang As Double
    Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single

    Application.ScreenUpdating = False

    ' 이전 시계판 지우기(바늘 포함 모든 시계 객체)
    DeleteByPrefix ws, "CLK_"

    ' 외곽 원판
    With ws.Shapes.AddShape(msoShapeOval, CX - R, CY - R, 2 * R, 2 * R)
        .name = "CLK_Dial"
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Line.Weight = 2
    End With

    ' 12개 눈금 + 숫자
    For i = 1 To 12
        ang = (i / 12) * 2 * PI - PI / 2

        ' 굵은 눈금
        x1 = CX + (R - 12) * Cos(ang): y1 = CY + (R - 12) * Sin(ang)
        x2 = CX + (R - 2) * Cos(ang): y2 = CY + (R - 2) * Sin(ang)
        With ws.Shapes.AddLine(x1, y1, x2, y2)
            .name = "CLK_Tick_" & i
            .Line.Weight = 2
        End With

        ' 숫자
        With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                CX + (R - 28) * Cos(ang) - 10, _
                CY + (R - 28) * Sin(ang) - 10, 30, 20)
            .name = "CLK_Num_" & i
            .TextFrame.Characters.Text = CStr(i)
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
            .Line.Visible = msoFalse
        End With
    Next

    ' 중심 캡
    With ws.Shapes.AddShape(msoShapeOval, CX - 4, CY - 4, 8, 8)
        .name = "CLK_Center"
        .Fill.ForeColor.RGB = RGB(0, 0, 0)
        .Line.Visible = msoFalse
    End With

    Application.ScreenUpdating = True
End Sub

' ===== 바늘 갱신 =====
Public Sub UpdateClock()
    Dim ws As Worksheet: Set ws = EnsureSheet(SHT)
    Dim h As Long, m As Long, s As Long
    Dim ang As Double
    Dim hLen As Single, mLen As Single, sLen As Single

    h = Hour(Now): m = Minute(Now): s = Second(Now)

    hLen = R * 0.5
    mLen = R * 0.7
    sLen = R * 0.85

    Application.ScreenUpdating = False

    ' 이전 바늘 안전 삭제 (개별 삭제 → 1004 방지)
    DeleteIfExists ws, "CLK_Hour"
    DeleteIfExists ws, "CLK_Minute"
    DeleteIfExists ws, "CLK_Second"

    ' 시침(분/초 반영)
    ang = ((h Mod 12) + m / 60# + s / 3600#) * (2 * PI / 12#) - PI / 2
    With ws.Shapes.AddLine(CX, CY, CX + hLen * Cos(ang), CY + hLen * Sin(ang))
        .name = "CLK_Hour"
        .Line.Weight = 4
    End With

    ' 분침(초 반영)
    ang = (m + s / 60#) * (2 * PI / 60#) - PI / 2
    With ws.Shapes.AddLine(CX, CY, CX + mLen * Cos(ang), CY + mLen * Sin(ang))
        .name = "CLK_Minute"
        .Line.Weight = 3
    End With

    ' 초침
    ang = s * (2 * PI / 60#) - PI / 2
    With ws.Shapes.AddLine(CX, CY, CX + sLen * Cos(ang), CY + sLen * Sin(ang))
        .name = "CLK_Second"
        .Line.Weight = 1
        .Line.ForeColor.RGB = RGB(200, 0, 0)
    End With

    Application.ScreenUpdating = True

    ' 1초 후 예약
    nextTime = Now + TimeSerial(0, 0, 1)
    Application.OnTime earliesttime:=nextTime, procedure:="UpdateClock"
End Sub

✍ 사용 방법

1️⃣ VBA 코드 붙여넣기

Alt + F11 → VBA 편집기 열기
새 모듈(Module) 생성 → 코드 전체 복사 & 붙여넣기

2️⃣ 시계 시작

StartClock

즉시 새로운 시트(Clock)에 시계가 생성됩니다.
초침이 1초마다 움직입니다.

3️⃣ 시계 정지

StopClock

타이머를 해제하여 시계 작동을 멈춥니다.

⚙ 주요 코드 포인트 설명

시계 그리기: DrawClockFace

외곽 원판: 중심 좌표(CX, CY), 반지름(R)
눈금 & 숫자: Cos, Sin을 활용한 원형 배치
중심 점: 작고 검은 원으로 표현

ang = (i / 12) * 2 * PI - PI / 2 x = CX + R * Cos(ang) y = CY + R * Sin(ang)

시간 바늘 그리기: UpdateClock

Now 함수로 시/분/초 추출
각도 계산 후 AddLine으로 바늘 그리기
기존 바늘은 삭제 후 새로 생성

실시간 동작 로직

nextTime = Now + TimeSerial(0, 0, 1) Application.OnTime earliesttime:=nextTime, procedure:="UpdateClock"

매 1초 후 UpdateClock 다시 실행
Windows 시간과 싱크되어 정확하게 작동

⚠ 주의사항

항목설명

실행 중 중단	Alt + Break 또는 StopClock을 호출해야 완전히 중단됩니다.
다중 실행	여러 번 실행 시 바늘 중복 가능 → 중복 방지 코드 포함됨
파일 저장	매크로 포함 파일로 저장하세요 (.xlsm)

마무리

"엑셀로 시계 만든다니... 진짜 될까?"

→ 됩니다!

아날로그 시계 만들기.xlsm

자재 명판 라벨 만들기 - ver1.1.xlsm

자재명판 라벨 문서 만들기(업그레이드 버전)

노만e — Mon, 8 Sep 2025 22:19:03 +0900

엑셀 자재명판 자동 생성하기 – VBA로 템플릿 복사부터 채우기까지 한 번에!

내가 원하는 자재의 템플릿을 만들고, 그 템플릿으로 나머지 자재 데이터를 채워넣는 기능이 있는 매크로 입니다.

이런 작업, 매번 손으로 하고 계신가요?

"자재명판 템플릿에 데이터를 하나씩 복사"
"복사한 후 행/열 간격 맞추고 레이아웃 정리"
"한 장씩 출력 배치, 눈으로 확인하면서 조정"

비효율적인 수작업, 이제 VBA 매크로로 자동화하세요.

목표: 자재리스트를 기반으로 템플릿 자동 복제 + 채우기

✔ 작업 흐름

단계내용

1️⃣	자재리스트 시트에서 데이터 자동 인식
2️⃣	자재명판 시트에서 템플릿 범위 직접 선택
3️⃣	가로로 몇 장 배치할지 입력 받음
4️⃣	각 자재 정보를 템플릿에 채워 복제
5️⃣	템플릿 간 공백/간격 자동 조정
6️⃣	최종 레이아웃 깔끔하게 정리됨

핵심 기능 요약

기능설명

템플릿 범위 직접 선택	원하는 레이아웃 범위를 직접 마우스로 드래그 선택
데이터 자동 매핑	자재명, 모델명, 규격 등 항목 자동 대응
배치 설정	"가로 몇 장 배치?" 질문창으로 유연하게 배치
✨ 레이아웃 통일	행 높이, 열 너비, 공백 크기 모두 일괄 반영
이전 내용 자동 초기화	기존 템플릿 아래 영역 자동 삭제 후 생성

실전 예시: 어떻게 활용하나요?

자재리스트 시트 예시

자재명모델명규격시리얼번호제조년월일

ABC모터	MX-200	150×90	20230815001	2023-08-15
BCD펌프	PX-400	200×120	20230705002	2023-07-05

자재명판 템플릿 예시

A열: 항목명 (자재명, 모델명, …)
B열: 해당 값 표시 영역

→ 복제 시 자동으로 값이 들어가며 행/열 간격도 맞춰짐

VBA 코드

Option Explicit

' ============================================
' 자재명판 템플릿 복사 & 자재리스트 채우기 (그리드 배치)
' - 템플릿 범위 직접 선택(Type:=8)
' - 가로 배치 개수 입력
' - 템플릿 사이 공백: 열 1칸, 행 1칸
' - 행높이/열너비는 템플릿과 동일
' - 공백 행(RowHeight=9) 적용
' - 출력 전에 템플릿 "이후 영역" 초기화
' ============================================
Public Sub 자재리스트_템플릿_복사_채우기_v3()

    Const SHT_LIST As String = "자재리스트"
    Const SHT_TPL  As String = "자재명판"
    Const H_GAP_COLS As Long = 1      ' 템플릿 사이 공백 열
    Const V_GAP_ROWS As Long = 1      ' 템플릿 사이 공백 행 개수
    Const GAP_ROW_HEIGHT As Double = 9
    Const GAP_COL_WIDTH As Double = 1

    Dim wsL As Worksheet, wsT As Worksheet
    Dim tpl As Range, tplTL As Range
    Dim rowsPerTpl As Long, colsPerTpl As Long
    Dim colsPerRow As Long

    Dim lastRow As Long, lastCol As Long, itemCnt As Long
    Dim headers As Object, leftLabels As Object
    Dim arrHeader, arrLbl, arrRow
    Dim r As Long, c As Long, n As Long
    Dim v, k
    Dim outStart As Range, tl As Range, blockRng As Range
    Dim gridRow As Long, gridCol As Long

    On Error GoTo EH

    Set wsL = ThisWorkbook.Worksheets(SHT_LIST)
    Set wsT = ThisWorkbook.Worksheets(SHT_TPL)

    ' 1) 템플릿 범위 선택
    If ActiveSheet.Name <> SHT_TPL Then wsT.Activate
    Set tpl = Application.InputBox( _
        Prompt:="자재명판 시트에서 템플릿 범위를 선택하세요.", _
        Title:="템플릿 범위 선택", Type:=8)
    If tpl Is Nothing Then Exit Sub

    rowsPerTpl = tpl.Rows.Count
    colsPerTpl = tpl.Columns.Count
    Set tplTL = tpl.Cells(1, 1)

    ' 2) 가로 배치 수 입력
    colsPerRow = CLng(Application.InputBox( _
        Prompt:="한 줄에 몇 장 배치할까요? (정수)", _
        Title:="가로 배치 개수", Type:=1))
    If colsPerRow < 1 Then Exit Sub


    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' 3) 자재리스트 건수/헤더 준비
    lastRow = wsL.Cells(wsL.Rows.Count, "A").End(xlUp).Row
    If lastRow < 2 Then GoTo Tidy
    lastCol = wsL.Cells(1, wsL.Columns.Count).End(xlToLeft).Column
    itemCnt = lastRow - 1

    Set headers = CreateObject("Scripting.Dictionary")
    arrHeader = wsL.Range(wsL.Cells(1, 1), wsL.Cells(1, lastCol)).Value
    For c = 1 To UBound(arrHeader, 2)
        v = Trim(CStr(arrHeader(1, c)))
        If Len(v) > 0 Then If Not headers.Exists(v) Then headers.Add v, c
    Next c

    Set leftLabels = CreateObject("Scripting.Dictionary")
    arrLbl = tpl.Columns(1).Value
    For r = 1 To rowsPerTpl
        v = Trim(CStr(arrLbl(r, 1)))
        If Len(v) > 0 Then If Not leftLabels.Exists(v) Then leftLabels.Add v, r
    Next r

    ' === 초기화: 템플릿 이후 영역 싹 지움 ===
    Set outStart = tplTL.Offset(rowsPerTpl + V_GAP_ROWS, 0)
    wsT.Range(outStart, wsT.Cells(wsT.Rows.Count, wsT.Columns.Count)).Clear

    ' 4) 반복 출력
    For n = 1 To itemCnt
        gridRow = (n - 1) \ colsPerRow
        gridCol = (n - 1) Mod colsPerRow

        Set tl = outStart.Offset( _
                 gridRow * (rowsPerTpl + V_GAP_ROWS), _
                 gridCol * (colsPerTpl + H_GAP_COLS))

        ' 템플릿 복사
        tpl.Copy
        wsT.Paste Destination:=tl
        Set blockRng = wsT.Range(tl, tl.Offset(rowsPerTpl - 1, colsPerTpl - 1))

        ' 행높이 동기화
        Dim i As Long
        For i = 1 To rowsPerTpl
            wsT.Rows(tl.Row + i - 1).rowHeight = tpl.Rows(i).rowHeight
        Next i

        ' 열너비 동기화
        For i = 1 To colsPerTpl
            wsT.Columns(tl.Column + i - 1).ColumnWidth = tpl.Columns(i).ColumnWidth
        Next i
        wsT.Columns(tl.Column + colsPerTpl).ColumnWidth = GAP_COL_WIDTH

        ' **공백 행 높이 = 9**
        wsT.Rows(tl.Row + rowsPerTpl).rowHeight = GAP_ROW_HEIGHT

        ' 값 채우기
        arrRow = wsL.Range(wsL.Cells(n + 1, 1), wsL.Cells(n + 1, lastCol)).Value
        For Each k In leftLabels.Keys
            If headers.Exists(CStr(k)) Then
                Dim rr As Long, cc As Long
                rr = CLng(leftLabels(k))
                cc = CLng(headers(k))
                blockRng.Cells(rr, 1).Offset(0, 1).Value = arrRow(1, cc)
            End If
        Next k
    Next n

Tidy:
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

EH:
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "실행 중 문제가 발생했습니다: " & Err.Description, vbExclamation
End Sub

✅ VBA 실행 방법

Alt + F11 → VBA 편집기 실행
새 모듈 추가 → 위 코드 붙여넣기
매크로 실행 (F5 또는 개발 도구 > 매크로 실행)
순서대로 선택/입력 (템플릿 범위 선택 → 가로 개수 입력)

❓ 자주 묻는 질문 (FAQ)

Q. 템플릿은 어느 시트에 있어야 하나요?
A. 자재명판 시트에 있어야 하며, 맨 위에 템플릿 형태로 구성되어야 합니다.

Q. 템플릿 복제할 때 폰트나 셀 병합은 유지되나요?
A. 네, 복사-붙여넣기로 동일한 레이아웃이 그대로 유지됩니다.

Q. 항목 이름이 약간 달라도 되나요?
A. 아니요, 자재리스트의 헤더명과 템플릿 라벨은 정확히 일치해야 자동 매핑됩니다.

Q. 템플릿 이후에 기존 데이터가 있으면 덮어쓰나요?
A. 기존 데이터는 복사 전에 자동 삭제됩니다. (원하는 경우 따로 백업해두세요.)

마무리: 엑셀 자동화, 어렵지 않아요!

자재명판 자동 생성 작업은
복잡할 것 같지만 한 번만 세팅하면 매번 1초 컷!

반복작업을 줄이고 실수를 방지할 수 있어
현업에서 아주 유용한 자동화 도구가 됩니다.

이 매크로가 도움되셨다면,
블로그 구독 + 공감 부탁드려요!

엑셀 VBA 우편 발송 라벨양식 자동 만들기

노만e — Mon, 8 Sep 2025 22:10:36 +0900

수작업으로 하나하나 주소 라벨 붙이고 계신가요?

거래처, 고객, 행사 대상자 우편 발송할 때…
한 사람씩 주소-이름-우편번호 넣는 작업, 지겹지 않으셨나요?

이제 VBA 매크로 하나로 끝낼 수 있습니다!
아래 코드를 사용하면, 엑셀 주소록 데이터를 기반으로
우편 라벨을 자동으로 채워주는 라벨지 양식을 만들 수 있어요.

✅ 매크로 기능 요약

기능설명

데이터 자동 읽기	주소록 시트의 이름/주소/우편번호 자동 인식
A~G열 × 3행 구조 라벨 자동 생성	출력 시트 라벨지에 깔끔한 박스 구성
정렬 및 줄맞춤 자동	주소, 이름, 우편번호 각기 다른 정렬 방식 적용
들여쓰기 + 글꼴 사이즈 자동 조정	실사용 레이아웃에 최적화
➕ 사용자 입력: 라벨 열 개수(가로 배치 수)
라벨 간격 자동 삽입	행 간격은 10pt / 열 간격도 자동 적용

준비 사항

1. 주소록 시트 구성 예시

이름주소우편번호

홍길동	서울시 강남구 테헤란로 10	06236
김영희	부산시 해운대구 해운대로	48093

B열: 이름, C열: 주소, D열: 우편번호 — 정확히 맞춰야 합니다.
A열은 사용하지 않습니다.

2. 출력용 시트는 자동 생성됩니다

이름: 라벨지
실행 시 해당 시트가 없으면 자동으로 새로 만들어줍니다.
이전에 있던 라벨 데이터는 자동 삭제됩니다.

✨ VBA 코드

Option Explicit

' A~G 열 × 1~3행 고정 레이아웃
' - B:이름, C:주소, D:우편번호 사용
' - 열 간격: 1칸, 행 간격: 10pt
Public Sub Make_Labels_AtoG_3rows_v3()
    Const SHT_SRC As String = "주소록"
    Const SHT_OUT As String = "라벨지"

    ' 고정 규격
    Const LABEL_W_COLS As Long = 7
    Const LABEL_H_ROWS As Long = 3
    Const GAP_COLS As Long = 1
    Const GAP_ROWS As Long = 1
    Const GAP_ROW_HEIGHT As Double = 10

    ' 기본값(열 수 2 또는 3일 때는 아래에서 덮어씀)
    Const LABEL_COL_WIDTH_DEFAULT As Double = 5     ' 기본 열너비
    Const GAP_COL_WIDTH As Double = 1.2             ' 간격 열너비
    Const ROW_H_ADDR As Double = 35                 ' 주소(1행) 높이
    Const ROW_H_NAME As Double = 20                 ' 이름(2행) 높이
    Const ROW_H_ZIP As Double = 20                  ' 우편(3행) 높이

    Dim wsSrc As Worksheet, wsOut As Worksheet
    Dim lastRow As Long, n As Long, labelsPerRow As Long
    Dim i As Long, idx As Long
    Dim startRow As Long, startCol As Long
    Dim labelColWidth As Double

    ' 가로 열 수 입력
    On Error GoTo CancelInput
    labelsPerRow = CLng(Application.InputBox("가로(열) 개수를 입력하세요.", "라벨 열 수", 2, Type:=1))
    If labelsPerRow < 1 Then Exit Sub
    On Error GoTo 0

    ' ▶ 열 수에 따른 열너비 자동 결정
    Select Case labelsPerRow
        Case 2: labelColWidth = 5
        Case 3: labelColWidth = 3
        Case Else: labelColWidth = LABEL_COL_WIDTH_DEFAULT
    End Select

    ' 시트
    Set wsSrc = ThisWorkbook.Worksheets(SHT_SRC)
    Set wsOut = EnsureSheet(SHT_OUT)
    wsOut.Cells.Clear

    ' 데이터 확인
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row
    n = lastRow - 1
    If n < 1 Then
        MsgBox "주소록 시트에 데이터가 없습니다. (B:이름, C:주소, D:우편번호)", vbExclamation
        Exit Sub
    End If

    ' 성능
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' 기본 셀 크기 적용
    wsOut.Cells.ColumnWidth = labelColWidth
    wsOut.Rows.RowHeight = ROW_H_NAME      ' 기본 20, 각 행에서 다시 조절

    ' 배치 시작
    startRow = 1: startCol = 1: idx = 0

    Dim nameTxt As String, addrTxt As String, zipTxt As String
    Dim addrRange As Range, nameRange As Range, zipRange As Range
    Dim labelBlock As Range

    For i = 2 To lastRow
        nameTxt = Trim$(wsSrc.Cells(i, "B").Value & "")
        addrTxt = Trim$(wsSrc.Cells(i, "C").Value & "")
        zipTxt = Trim$(wsSrc.Cells(i, "D").Value & "")

        ' 블록: A~G × 3행
        Set labelBlock = wsOut.Range(wsOut.Cells(startRow, startCol), _
                                     wsOut.Cells(startRow + LABEL_H_ROWS - 1, startCol + LABEL_W_COLS - 1))

        ' 각 행 범위
        Set addrRange = wsOut.Range(wsOut.Cells(startRow, startCol), _
                                    wsOut.Cells(startRow, startCol + LABEL_W_COLS - 1))
        Set nameRange = wsOut.Range(wsOut.Cells(startRow + 1, startCol), _
                                    wsOut.Cells(startRow + 1, startCol + LABEL_W_COLS - 1))
        Set zipRange = wsOut.Range(wsOut.Cells(startRow + 2, startCol), _
                                    wsOut.Cells(startRow + 2, startCol + LABEL_W_COLS - 1))

        ' 주소행
        SafeUnmerge addrRange: addrRange.Merge
        With addrRange
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Value = addrTxt
            .Font.Size = 11
        End With
        wsOut.Rows(startRow).RowHeight = ROW_H_ADDR

        ' 이름행 (오른쪽 정렬 + 들여쓰기 1)
        SafeUnmerge nameRange: nameRange.Merge
        With nameRange
            .HorizontalAlignment = xlRight
            .VerticalAlignment = xlCenter
            .WrapText = False
            .IndentLevel = 1                 ' ▶ 오른쪽에서 들여쓰기 1
            .Value = nameTxt & "  귀하"
            .Font.Size = 12
            If Len(nameTxt) > 0 Then .Characters(Start:=Len(nameTxt) + 3, Length:=2).Font.Size = 10
        End With
        wsOut.Rows(startRow + 1).RowHeight = ROW_H_NAME

        ' 우편번호행
        SafeUnmerge zipRange: zipRange.Merge
        With zipRange
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Value = zipTxt
            .Font.Size = 11
        End With
        wsOut.Rows(startRow + 2).RowHeight = ROW_H_ZIP

        ' 바깥 테두리만
        With labelBlock.Borders(xlInsideHorizontal): .LineStyle = xlNone: End With
        With labelBlock.Borders(xlInsideVertical):   .LineStyle = xlNone: End With
        labelBlock.Borders.LineStyle = xlNone
        labelBlock.BorderAround Weight:=xlThick, LineStyle:=xlContinuous, Color:=RGB(120, 120, 120)

        ' 다음 위치
        idx = idx + 1
        If (idx Mod labelsPerRow) <> 0 Then
            ' 같은 행의 다음 라벨로 이동: +7열 + 간격1열
            startCol = startCol + LABEL_W_COLS
            wsOut.Columns(startCol).ColumnWidth = GAP_COL_WIDTH
            startCol = startCol + GAP_COLS
        Else
            ' 다음 행으로 이동: +3행 + 간격행(10pt)
            startCol = 1
            startRow = startRow + LABEL_H_ROWS
            wsOut.Rows(startRow).RowHeight = GAP_ROW_HEIGHT
            startRow = startRow + GAP_ROWS
        End If
    Next i

    wsOut.Activate
    Application.Goto wsOut.Range("A1"), True

Tidy:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "라벨 생성 완료!", vbInformation
    Exit Sub

CancelInput:
    MsgBox "작업이 취소되었습니다.", vbInformation
End Sub

' --- 안전 병합해제 ---
Private Sub SafeUnmerge(ByVal rng As Range)
    On Error Resume Next
    If Not rng Is Nothing Then rng.UnMerge
    On Error GoTo 0
End Sub

' --- 출력 시트 보장 ---
Private Function EnsureSheet(ByVal name As String) As Worksheet
    On Error Resume Next
    Set EnsureSheet = ThisWorkbook.Sheets(name)
    On Error GoTo 0
    If EnsureSheet Is Nothing Then
        Set EnsureSheet = ThisWorkbook.Sheets.Add
        EnsureSheet.name = name
    End If
End Function

매크로 실행 방법

Alt + F11 → VBA 편집기 열기
새 모듈 추가 → 위 코드 붙여넣기
실행 (F5) 또는 매크로 등록 후 실행
"가로 라벨 개수" 입력 (예: 2 또는 3)

✨ 실행 결과 미리보기

가로 2개 라벨로 선택 시, 아래처럼 배치됩니다:

┌──────────────┬──────────────┐ │ 서울시 강남구… │ 부산시 해운대… │ ← 주소 (상단) │ 홍길동 귀하 │ 김영희 귀하 │ ← 이름 (중앙) │ 06236 │ 48093 │ ← 우편번호 (하단) └──────────────┴──────────────┘

주소: 상단 정렬, 글꼴 크기 11pt
이름: 오른쪽 정렬, 들여쓰기, “귀하” 자동 추가
우편번호: 가운데 정렬
박스 테두리 자동 처리 (진한 테두리만 표시)

팁: 조정 가능한 부분

항목설명변수명

라벨 너비	라벨 한 칸당 열 너비	labelColWidth
라벨 높이	주소/이름/우편번호 각각의 행 높이	ROW_H_ADDR, ROW_H_NAME, ROW_H_ZIP
라벨 간격 (행)	라벨 사이 줄 간격 (단위: pt)	GAP_ROW_HEIGHT
라벨 간격 (열)	라벨 사이 열 간격	GAP_COL_WIDTH

❓ 자주 묻는 질문 (Q&A)

Q. 이름에 ‘귀하’는 자동으로 붙나요?
A. 네, "홍길동 귀하" 형식으로 자동 완성됩니다. 폰트 크기도 자동 조정됩니다.

Q. 라벨 간격이 너무 좁아요. 넓힐 수 있나요?
A. GAP_ROW_HEIGHT, GAP_COL_WIDTH 값을 늘리면 간격이 더 넓어집니다.

Q. 주소가 너무 길면 잘리나요?
A. 아니요! 자동 줄바꿈 기능이 적용되어 넉넉하게 표시됩니다.

마무리

엑셀 VBA를 활용하면 반복적인 레이아웃 작업도
단 1초 만에 자동화할 수 있습니다.

한 번 코드를 붙여두면,
앞으로 수십 수백 명의 라벨 작업도 클릭 한 번이면 끝!

이런 자동화 콘텐츠 유용하셨다면
블로그 구독과 공감으로 응원해주세요!

우편 발송 라벨지 만들기.xlsm

파일을 팀별 폴더로 이동하기

노만e — Sat, 6 Sep 2025 05:24:16 +0900

엑셀 VBA로 폴더 안 파일 자동 분류하기 – 팀/파트별로 자동 이동!

반복되는 파일 정리, 지치지 않으셨나요?

업무를 하다 보면
다양한 부서나 팀에서 만든 수많은 파일을
"이름을 보고 하나하나 폴더에 넣는" 일을 자주 하게 됩니다.

예를 들어, 아래처럼 된 파일들이 수십~수백 개 있다고 해볼게요:

기획_전략_이순신.xlsx 디자인-UX-김유신.pdf 마케팅 콘텐츠 박지성.hwp 개발.백엔드.장보고.pptx

이걸 하나하나 폴더를 만들고 정리한다면?
시간 낭비는 물론, 실수도 많고 지칩니다.

그래서 준비했습니다.

엑셀 VBA 매크로로 자동 분류하는 방법은?

이 매크로는
파일명을 분석해서 \팀\파트\파일명 구조로 자동 정리해주는 도구입니다.

✅ 작동 방식:

파일명에서 팀과 파트를 자동으로 인식합니다
- _, -, 공백, . 구분자 모두 허용
- 예: 기획_전략_파일명 → 기획\전략\파일명
해당 폴더가 없으면 자동 생성
같은 이름 파일이 있으면 자동으로 (1), (2) 붙여 저장
모든 확장자(.xlsx, .pptx, .pdf 등) 지원
드라이브 간 이동도 안전하게 처리

✅ 예시:

기획 └ 전략 └ 이순신.xlsx 디자인 └ UX └ 김유신.pdf

❓ 자주 묻는 질문

Q. 파일명이 완전히 규칙적이지 않아도 되나요?
A. 어느 정도 규칙만 있으면 됩니다.
구분자는 _, -, 공백, . 등을 모두 자동 인식합니다.

Q. 이름 중에 한글/영문/숫자 모두 사용 가능한가요?
A. 예, 유니코드 안전하게 처리됩니다.

Q. 기존 폴더나 파일과 겹치면 어떻게 되나요?
A. 같은 파일명이 있으면 (1), (2) 자동 넘버링되어 저장됩니다.

⚙️ 사용 방법

Alt + F11 → 엑셀 VBA 편집기 실행
새 모듈 삽입 → 위 코드 전체 붙여넣기
F5 또는 단축키로 OrganizeFilesByTeamPart 실행
정리할 폴더를 선택하면 끝!

VBA 코드

Option Explicit

'==========================================================
'  \팀\파트\파일  구조로 분류/이동 (v3-all-clean: 로그 제거)
'  - 파일명 규칙: 팀_파트_이름.* / 팀-파트-이름.* / "팀 파트 이름.*" / 점(.)도 허용
'  - 확장자 구분 없음: 모든 파일 이동
'  - 이동: FSO.MoveFile (드라이브 간/유니코드 안정)
'==========================================================

Public Sub OrganizeFilesByTeamPart()
    On Error GoTo EH

    Dim rootFolder As String: rootFolder = PickFolder("정리할 폴더를 선택하세요")
    If Len(rootFolder) = 0 Then Exit Sub
    If Right$(rootFolder, 1) <> "\" Then rootFolder = rootFolder & "\"

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(rootFolder) Then MsgBox "폴더가 없습니다: " & rootFolder: Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim f As Object
    Dim team As String, part As String
    Dim destTeam As String, destPart As String
    Dim destFileFull As String

    For Each f In fso.GetFolder(rootFolder).Files
        If ParseTeamPartFlexible(f.Name, team, part) Then
            team = SafeFolderName(team): If Len(team) = 0 Then team = "팀미정"
            part = SafeFolderName(part): If Len(part) = 0 Then part = "파트미정"

            destTeam = rootFolder & team & "\"
            destPart = destTeam & part & "\"

            If EnsureFolderDeepFSO(fso, destTeam) And EnsureFolderDeepFSO(fso, destPart) Then
                destFileFull = GetUniquePathFSO(fso, destPart, f.Name)
                If IsValidPath(destFileFull) Then
                    If StrComp(NormalizePath(f.Path), NormalizePath(destFileFull), vbTextCompare) <> 0 Then
                        On Error Resume Next
                        fso.MoveFile f.Path, destFileFull
                        Err.Clear
                        On Error GoTo EH
                    End If
                End If
            End If
        End If
    Next f

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "정리 완료!", vbInformation
    Exit Sub

EH:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "오류: " & Err.Number & " - " & Err.Description, vbExclamation
End Sub

'---------------------------- 파서 ----------------------------
Private Function ParseTeamPartFlexible(ByVal fileName As String, _
                                       ByRef team As String, ByRef part As String) As Boolean
    Dim base As String: base = GetFileNameNoExt(fileName)
    Dim s As String: s = Trim$(base)
    ' 구분자 통합: -, 공백, 탭, 점(.) → _
    s = Replace(Replace(Replace(Replace(s, "-", "_"), " ", "_"), vbTab, "_"), ".", "_")

    Dim toks As Variant: toks = Split(s, "_")
    If IsArray(toks) Then
        If UBound(toks) >= 1 Then
            team = Trim$(toks(0))
            part = Trim$(toks(1))
            ParseTeamPartFlexible = (Len(team) > 0 And Len(part) > 0)
        End If
    End If
End Function

'---------------------------- 파일/폴더 유틸 (FSO 버전) ----------------------------
Private Function EnsureFolderDeepFSO(ByVal fso As Object, ByVal folderPath As String) As Boolean
    On Error GoTo EH
    Dim p As String: p = folderPath
    If Right$(p, 1) = "\" Then p = Left$(p, Len(p) - 1)
    If Len(p) = 0 Then EnsureFolderDeepFSO = False: Exit Function

    Dim parts() As String, i As Long, acc As String
    parts = Split(p, "\")

    If IsUNCPath(p) Then
        If UBound(parts) < 3 Then EnsureFolderDeepFSO = True: Exit Function  ' \\server\share
        acc = "\\" & parts(2) & "\" & parts(3)
        If Not fso.FolderExists(acc) Then fso.CreateFolder acc
        For i = 4 To UBound(parts)
            acc = acc & "\" & parts(i)
            If Not fso.FolderExists(acc) Then fso.CreateFolder acc
        Next i
    Else
        acc = parts(0)
        For i = 1 To UBound(parts)
            acc = acc & "\" & parts(i)
            If Not fso.FolderExists(acc) Then fso.CreateFolder acc
        Next i
    End If
    EnsureFolderDeepFSO = True
    Exit Function
EH:
    EnsureFolderDeepFSO = False
End Function

Private Function GetUniquePathFSO(ByVal fso As Object, ByVal baseFolder As String, ByVal fileName As String) As String
    If Right$(baseFolder, 1) <> "\" Then baseFolder = baseFolder & "\"
    Dim nameNoExt As String: nameNoExt = GetFileNameNoExt(fileName)
    Dim ext As String: ext = GetFileExt(fileName)
    Dim tryPath As String: tryPath = baseFolder & nameNoExt & IIf(ext <> "", "." & ext, "")
    If Not fso.FileExists(tryPath) Then
        GetUniquePathFSO = tryPath: Exit Function
    End If
    Dim n As Long: n = 1
    Do
        tryPath = baseFolder & nameNoExt & " (" & n & ")" & IIf(ext <> "", "." & ext, "")
        If Not fso.FileExists(tryPath) Then GetUniquePathFSO = tryPath: Exit Function
        n = n + 1
    Loop
End Function

Private Function GetFileExt(ByVal fileName As String) As String
    Dim p As Long: p = InStrRev(fileName, ".")
    If p > 0 Then GetFileExt = Mid$(fileName, p + 1) Else GetFileExt = ""
End Function

Private Function GetFileNameNoExt(ByVal fileName As String) As String
    Dim p As Long: p = InStrRev(fileName, ".")
    If p > 0 Then GetFileNameNoExt = Left$(fileName, p - 1) Else GetFileNameNoExt = fileName
End Function

Private Function SafeFolderName(ByVal s As String) As String
    Dim bad As Variant, i As Long
    bad = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For i = LBound(bad) To UBound(bad)
        s = Replace$(s, bad(i), " ")
    Next
    s = Trim$(s)
    Do While Len(s) > 0 And (Right$(s, 1) = "." Or Right$(s, 1) = " ")
        s = Left$(s, Len(s) - 1)
    Loop
    ' 예약 장치명 회피
    Dim dev As Variant
    dev = Array("CON", "PRN", "AUX", "NUL", _
                "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", _
                "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9")
    For i = LBound(dev) To UBound(dev)
        If StrComp(s, CStr(dev(i)), vbTextCompare) = 0 Then s = s & "_"
    Next
    SafeFolderName = s
End Function

Private Function NormalizePath(ByVal p As String) As String
    If Right$(p, 1) = "\" Then p = Left$(p, Len(p) - 1)
    NormalizePath = p
End Function

Private Function IsValidPath(ByVal p As String) As Boolean
    IsValidPath = True
    If Len(p) > 259 Then IsValidPath = False: Exit Function
    If Len(p) > 0 Then
        If Right$(p, 1) = "." Or Right$(p, 1) = " " Then IsValidPath = False
    End If
End Function

Private Function IsUNCPath(ByVal p As String) As Boolean
    IsUNCPath = (Len(p) >= 2 And Left$(p, 2) = "\\")
End Function

'---------------------------- 폴더 선택 ----------------------------
Private Function PickFolder(ByVal title As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .title = title
        .AllowMultiSelect = False
        If .Show = -1 Then PickFolder = .SelectedItems(1) Else PickFolder = ""
    End With
End Function

✨ 이런 분께 강력 추천합니다

팀 파일을 체계적으로 정리하고 싶은 분
문서 자동 분류 시스템이 필요한 관리자
보고서, 자료, 산출물이 많은 부서 담당자
매번 수작업으로 정리하다 지친 실무자

✅ 마무리 요약

기능설명

파일 정리 기준	팀_파트_이름.* 형식
자동 생성 폴더	팀\파트 구조로 생성
파일 처리 방식	이동 (MoveFile 사용)
지원 확장자	제한 없음 (모든 파일)

이 매크로 하나면,
1초 만에 수백 개의 파일을 체계적으로 정리할 수 있습니다.

실무 자동화 VBA 매크로, 더 받아보고 싶으신가요?
블로그 구독하고 최신 매크로 예제 받아보기

파일을 팀별 폴더로 이동하기.xlsm

자재명판 라벨 문서 만들기

노만e — Thu, 4 Sep 2025 22:51:40 +0900

자재명판을 매번 복사해서 붙여넣으시나요?

현장에서 자재명판을 출력하거나, 제품 라벨을 준비할 때
하나하나 복사해서 내용을 바꾸고 붙이는 반복 작업에 시간을 쓰고 계시다면
이 매크로 하나면 업무 시간을 90% 이상 단축시킬 수 있습니다.

특히 자재 리스트가 수십, 수백 개일 경우엔
자동화의 효과가 훨씬 더 커지게 됩니다.

엑셀에서 자재명판을 자동으로 만들 수 있을까요?

오늘 소개하는 이 엑셀 VBA 매크로는
자재 리스트에서 데이터를 읽고,
사용자가 지정한 템플릿을 **수량만큼 자동 복제**하여
각 항목에 맞게 자재 정보를 채워 넣는 도구입니다.

또한 가로 개수, 간격, 행 높이까지 입력 받아
**자유롭게 그리드 형태로 배치**되므로
A4 출력 기준 라벨 작업에도 바로 활용할 수 있습니다.

이 매크로의 핵심 기능은 다음과 같습니다:

1. 템플릿 범위를 직접 선택 (자재명, 모델명, 규격 등 포함 영역)
2. 자재리스트(A~E열)에 있는 데이터를 행 단위로 읽음
3. 자재 수만큼 템플릿을 복사하여 시트에 자동 배치
4. 각 블록에 자재 데이터를 자동으로 입력
5. 외곽 테두리 적용 + 병합 셀 포함 영역도 안정 처리
6. 시리얼 번호는 텍스트 형식으로 유지
7. 제작일(제조년월일)은 날짜 형식으로 자동 포맷 적용

활용 예시는 다음과 같습니다:

- 제품 라벨, 명판 자동 출력
- 교육용 카드 제작
- 시리얼 넘버 및 제조정보가 포함된 명세서 자동 생성
- 라벨지 출력용 그리드 배치 자동화
- 출력물을 위한 A4 맞춤 데이터 정리

사용 방법도 매우 간단합니다:

1. 자재명판 시트에 샘플 템플릿을 만듭니다 (2~5행 정도)
2. 자재리스트 시트에 데이터(자재명, 모델명 등)를 입력
3. 매크로 실행 후, 템플릿 범위를 마우스로 선택
4. 가로 개수, 간격, 행 높이 입력
5. 자동으로 템플릿이 복제되어 데이터가 채워집니다

매번 수작업으로 만들던 자재명판,
이제는 버튼 한 번이면 끝입니다.

이 매크로의 장점은 다음과 같습니다:

- 템플릿 범위를 자유롭게 설정 가능 (어떤 형태도 적용 가능)
- 데이터 개수만큼 자동 생성 (누락 없음)
- 간격, 정렬, 배치 방식 사용자 정의
- 시리얼번호나 날짜 포맷도 안전 처리
- 시트 영역 자동 정리 기능 포함 (기존 내용 삭제)

VBA 코드

Option Explicit

' ============================================
' 버튼: 자재 리스트 가져오기 (템플릿 범위 선택형)
' 1) 템플릿 범위를 직접 선택(Type:=8)
' 2) 자재리스트(A:E 헤더 기준) 읽기
' 3) 선택 템플릿을 수량만큼 복사 & 각 블록 채우기
' 4) 가로 배치 개수/간격도 입력받아 그리드 배치
' ============================================
Public Sub 자재리스트_가져오기_템플릿선택()
    Const SRC As String = "자재리스트"
    Const DST As String = "자재명판"

    Dim wsS As Worksheet, wsD As Worksheet
    Dim tpl As Range, tplTL As Range
    Dim blkW As Long, blkH As Long
    Dim colsPerRow As Long, hGap As Long, vGap As Long
    Dim map As Object
    Dim lastRow As Long, r As Long, n As Long
    Dim rowIdx As Long, colIdx As Long
    Dim tgtTL As Range, tgtBlk As Range
    Dim dat(1 To 5) As Variant
    Dim rowHeight As Double
    Dim doClear As VbMsgBoxResult

    Set wsS = ThisWorkbook.Worksheets(SRC)
    Set wsD = ThisWorkbook.Worksheets(DST)

    ' 1) 템플릿 범위 선택 (자재명판 시트에서)
    On Error Resume Next
    Set tpl = Application.InputBox( _
        Prompt:="자재명판의 '템플릿 샘플 범위'를 드래그해 선택하세요." & vbCrLf & _
                "예: 자재명/모델명/규격/시리얼번호/제조년월일 2열짜리 표 전체", _
        Title:="명판 템플릿 선택", Type:=8)
    On Error GoTo 0

    If tpl Is Nothing Then Exit Sub
    If tpl.Parent.Name <> wsD.Name Then
        MsgBox "템플릿 범위는 '자재명판' 시트에서 선택해주세요.", vbExclamation
        Exit Sub
    End If

    Set tplTL = tpl.Cells(1, 1)
    blkW = tpl.Columns.Count
    blkH = tpl.Rows.Count

    ' 2) 자재리스트 헤더 매핑
    Set map = HeaderMap(wsS.Rows(1), Array("자재명", "모델명", "규격", "시리얼번호", "제조년월일"))
    If map Is Nothing Then
        MsgBox "자재리스트 머리글(자재명/모델명/규격/시리얼번호/제조년월일)을 찾을 수 없습니다.", vbExclamation
        Exit Sub
    End If

    lastRow = wsS.Cells(wsS.Rows.Count, map("자재명")).End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "자재리스트에 데이터가 없습니다.", vbInformation
        Exit Sub
    End If

    ' 3) 배치 파라미터
    colsPerRow = CLng(Application.InputBox("가로 몇 장 배치할까요?", "가로 개수", 2, Type:=1))
    hGap = CLng(Application.InputBox("블록 사이 열 간격(빈 열 수)?", "가로 간격", 1, Type:=1))
    vGap = CLng(Application.InputBox("블록 사이 행 간격(빈 행 수)?", "세로 간격", 1, Type:=1))
    rowHeight = CDbl(Application.InputBox("블록 내 행 높이(기본 22)?", "행 높이", 22, Type:=1))

    ' 4) 기존 생성물 정리 여부
    doClear = MsgBox("선택한 템플릿의 오른쪽/아래 영역을 지우고 다시 생성할까요?", _
                     vbQuestion + vbYesNo, "생성 전 정리")

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    If doClear = vbYes Then
        ClearGeneratedArea wsD, tplTL, blkW, blkH
    End If

    ' 5) 생성 루프
    n = 0
    Dim rData As Long
    For rData = 2 To lastRow
        n = n + 1

        ' 그리드 배치 좌표
        rowIdx = (n - 1) \ colsPerRow
        colIdx = (n - 1) Mod colsPerRow

        Set tgtTL = tplTL.Offset(rowIdx * (blkH + vGap), colIdx * (blkW + hGap))
        Set tgtBlk = wsD.Range(tgtTL, tgtTL.Offset(blkH - 1, blkW - 1))

        ' 템플릿 복사
        tpl.Copy
        tgtTL.PasteSpecial xlPasteAll

        ' 행 높이 통일 + 외곽 굵게/내부 얇게
        SetBlockRowHeights tgtBlk, rowHeight
        ApplyBlockBorders tgtBlk

        ' 데이터 읽기
        dat(1) = wsS.Cells(rData, map("자재명")).Value2
        dat(2) = wsS.Cells(rData, map("모델명")).Value2
        dat(3) = wsS.Cells(rData, map("규격")).Value2
        dat(4) = CStr(wsS.Cells(rData, map("시리얼번호")).Value) ' 텍스트 고정
        dat(5) = wsS.Cells(rData, map("제조년월일")).Value2

        ' 필드 주입(템플릿 내부에서 제목 텍스트를 찾아 오른쪽 칸에 값 입력)
        FillFieldInBlock tgtBlk, "자재명", dat(1)
        FillFieldInBlock tgtBlk, "모델명", dat(2)
        FillFieldInBlock tgtBlk, "규격", dat(3)
        FillFieldInBlock tgtBlk, "시리얼번호", dat(4), True
        FillFieldInBlock tgtBlk, "제조년월일", dat(5)
    Next rData

    ' 루프 끝난 후: gap 행 높이 조정
Call SetGapRowHeights(tplTL, blkH, vGap, lastRow - 1, colsPerRow)

Tidy:
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "자재명판 생성 완료!", vbInformation
End Sub

' ---------------------- 유틸 ----------------------

' 머리글 매핑: 필요한 머리글이 모두 있으면 Dictionary 반환
Private Function HeaderMap(ByVal headerRow As Range, ByVal needArr As Variant) As Object
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    Dim lastCol As Long, c As Long, t As String, i As Long
    lastCol = headerRow.Cells(1, headerRow.Parent.Columns.Count).End(xlToLeft).Column
    For c = 1 To lastCol
        t = Trim(CStr(headerRow.Cells(1, c).Value))
        If Len(t) > 0 Then
            If Not d.Exists(t) Then d.Add t, c
        End If
    Next
    For i = LBound(needArr) To UBound(needArr)
        If Not d.Exists(CStr(needArr(i))) Then Exit Function
    Next
    Set HeaderMap = d
End Function

' 블록 내부에서 제목 텍스트를 찾아 옆 칸에 값 기록
' serialText=True → 텍스트 서식으로 고정(시리얼번호 보존)
Private Sub FillFieldInBlock(ByVal blk As Range, ByVal titleText As String, _
                             ByVal valueIn As Variant, Optional ByVal serialText As Boolean = False)
    Dim f As Range
    ' 라벨이 "자재명:"처럼 콜론 포함인 경우도 대비 → 부분 일치
    Set f = blk.Find(What:=titleText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If Not f Is Nothing Then
        With f.Offset(0, 1)
            If serialText Then
                .NumberFormat = "@"
                .Value = CStr(valueIn)
            ElseIf titleText = "제조년월일" Then
                .NumberFormat = "yyyy-mm-dd"
                .Value = valueIn
            Else
                .Value = valueIn
            End If
        End With
    End If
End Sub

' 블록 내 행 높이 동일화
Private Sub SetBlockRowHeights(ByVal blk As Range, ByVal h As Double)
    Dim i As Long
    For i = 1 To blk.Rows.Count
        blk.Rows(i).rowHeight = h
    Next
End Sub

' 블록과 블록 사이 행 높이를 9로 세팅
Private Sub SetGapRowHeights(ByVal tplTL As Range, ByVal blkH As Long, ByVal vGap As Long, ByVal totalBlocks As Long, ByVal colsPerRow As Long)
    Dim i As Long, rowIdx As Long, gapRow As Long
    Dim ws As Worksheet
    Set ws = tplTL.Worksheet

    ' 각 행 단위 배치마다, 블록과 블록 사이 gap 행 높이 = 9
    For i = 1 To totalBlocks
        rowIdx = (i - 1) \ colsPerRow
        If (i Mod colsPerRow) = 0 Then
            ' 이 줄이 끝나면 gap 아래쪽 행 지정
            gapRow = tplTL.Row + rowIdx * (blkH + vGap) + blkH
            If vGap > 0 Then
                ws.Rows(gapRow).rowHeight = 9
            End If
        End If
    Next i
End Sub

' 블록 테두리: 외곽 굵게, 내부 얇게
Private Sub ApplyBlockBorders(ByVal blk As Range)
    With blk.Borders
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Item(xlInsideVertical).Weight = xlThin
        .Item(xlInsideHorizontal).Weight = xlThin
        .Item(xlEdgeLeft).Weight = xlThick
        .Item(xlEdgeRight).Weight = xlThick
        .Item(xlEdgeTop).Weight = xlThick
        .Item(xlEdgeBottom).Weight = xlThick
    End With
End Sub

' 선택 템플릿의 오른쪽/아래 영역만 정리 (템플릿은 보존)
Private Sub ClearGeneratedArea(ByVal ws As Worksheet, ByVal tplTL As Range, _
                               ByVal blkW As Long, ByVal blkH As Long)
    Dim ur As Range, clearRg As Range
    Set ur = ws.UsedRange
    On Error Resume Next
    Set clearRg = ws.Range(tplTL.Offset(blkH, 0), ws.Cells(ws.Rows.Count, ws.Columns.Count))
    If Not clearRg Is Nothing Then clearRg.Clear
    Set clearRg = ws.Range(tplTL.Offset(0, blkW), tplTL.Offset(blkH - 1, ws.Columns.Count))
    If Not clearRg Is Nothing Then clearRg.Clear
    On Error GoTo 0
End Sub

정리하며

현장에서 바로 쓸 수 있는 엑셀 매크로를 찾고 계셨다면
이 자재명판 자동 생성기만큼 실용적인 매크로는 드뭅니다.

단순한 반복 작업을 줄이고
정확하고 빠르게 자재명판을 만들고 싶다면
지금 이 매크로를 사용해보세요.

더 많은 실무용 자동화 매크로를 받아보고 싶으시다면
블로그 구독하고 실전 예제를 계속 받아보세요.

감사합니다.

자재 명판 라벨 만들기.xlsm

특정 색을 가진 셀만 골라 일렬로 나열하기.xlsm

셀 색상 기준으로 데이터를 자동 분류

노만e — Tue, 2 Sep 2025 08:08:17 +0900

셀 색상 기준으로 데이터를 자동 분류하는 엑셀 매크로가 있다면 어떨까요?

업무 중 데이터에 색상을 칠해서 시각적으로 구분하는 경우 많으시죠?
예를 들어 상태별로 색을 다르게 넣는다든지, 담당자마다 셀 색을 바꾸는 방식으로
중요 항목을 구분하는 일이 자주 발생합니다.

하지만 그 색상을 기준으로 다시 정리해야 할 때는 어떻게 하시나요?

손으로 필터하고 복사해서 다른 시트에 붙여넣는 방식,
번거롭고 실수가 생기기 쉽습니다.

오늘 소개할 엑셀 VBA 매크로는
이런 문제를 단 몇 초 만에 완벽하게 해결해줍니다.

색상별로 셀을 분류해 자동으로 모아주는 VBA 매크로

이 매크로는 사용자가 선택한 데이터 범위에서
**셀의 채우기 색상(Interior.Color)을 기준으로**
자동으로 데이터를 색상별로 분류하고
지정한 위치에 **세로 방향 컬럼 형태로 출력**해줍니다.

핵심 기능은 다음과 같습니다:

1. 원본 데이터에서 색상이 있는 셀만 감지
2. 같은 색상의 셀들을 하나의 컬럼으로 묶어 출력
3. 첫 행에는 해당 색상을 그대로 배경으로 표시 (헤더 역할)
4. 값은 물론 **수식과 숫자 서식(NumberFormat)**까지 그대로 유지
5. 병합 셀도 안전하게 처리 (좌상단 셀만 수집)

실제 사용 예시:

- 프로젝트 상태별 데이터 정리 (완료, 진행, 보류 등 색상 구분)
- 담당자별 이슈 분류 (색상별 담당자 표시)
- 우선순위별 작업 리스트 정리 (빨강=긴급, 노랑=보통, 초록=완료 등)

이 매크로를 실행하는 방법은 매우 간단합니다:

1. 색상 기준으로 정리할 **원본 데이터를 선택**
2. 결과를 출력할 **시작 셀(단일 셀)을 선택**
3. 매크로를 실행하면, 자동으로 색상별로 그룹화된 컬럼이 정렬됨
4. 각 컬럼의 첫 번째 셀은 색상 헤더로 구분됨

예를 들어, 빨간색으로 칠해진 항목은 첫 번째 컬럼,
파란색은 두 번째 컬럼, 노란색은 세 번째 컬럼 형태로
**가로로 색상 그룹화된 표**가 생성됩니다.

이 매크로는 다음과 같은 특징이 있습니다:

- **조건부서식과 무관**: 실제 셀의 채우기 색상만 기준으로 함
- **병합 셀도 중복 없이 한 번만 수집**
- **색상 순서는 등장한 순서대로 유지**
- **숨겨진 행이나 열도 무시하고 전체 처리**
- **수식이 있는 셀은 수식 그대로 유지**

업무에 어떤 도움을 줄 수 있을까요?

- 데이터 분류 속도 비약적으로 향상
- 색상 기준 업무 자동화 가능
- 복잡한 필터/정렬 없이 시각적 기준으로 자료 재구성
- 데이터를 시각적으로 정리하고 싶은 모든 상황에 적용 가능

정리하며

단순해 보이지만 실제로는 수작업으로 해결하기 어려운 문제를
이 한 줄의 매크로가 완벽하게 해결해줍니다.

엑셀의 셀 색상을 의미 있게 활용하고 싶다면
이 매크로는 반드시 즐겨찾기에 추가해두세요.

엑셀 자동화, 이제 눈에 보이는 색상만으로도 가능합니다.

더 많은 엑셀 실무 자동화 팁을 받아보고 싶다면
지금 블로그를 구독하고 실무 매크로 노하우를 챙겨가세요.

감사합니다.

엑셀 VBA 셀 범위 선택만으로 원하는 이름의 시트 생성하기

노만e — Sat, 30 Aug 2025 15:26:01 +0900

엑셀에서 셀 내용을 기준으로 시트를 자동 생성하고 싶으신가요?

엑셀을 활용하다 보면
부서명, 프로젝트명, 고객명 등
특정 리스트를 기준으로 여러 개의 시트를 만들어야 할 일이 자주 생깁니다.

하지만 시트를 하나씩 수동으로 만들고 이름을 붙이는 작업은
단순하면서도 가장 비효율적인 반복 업무 중 하나입니다.

그럴 때 바로 이 매크로 하나면 해결됩니다.

셀 범위에서 이름을 읽어 자동으로 시트를 생성하는 방법은?

오늘 소개할 `CreateSheetsFromRange()` 매크로는
사용자가 선택한 셀 범위의 값을 기준으로
자동으로 새로운 시트를 만들어주는 도구입니다.

예를 들어, 아래와 같이 A열에 항목이 있을 때:
영업부
총무부
개발팀
개발팀

위 값을 선택하고 매크로를 실행하면
동일한 이름이 중복될 경우 자동으로 "_1", "_2" 식의 일련번호가 붙으며
총 4개의 시트가 자동 생성됩니다.

즉, 결과 시트 이름은 다음과 같이 생성됩니다:
영업부
총무부
개발팀
개발팀_1

코드의 핵심 기능은 다음과 같습니다:

1. 사용자가 직접 셀 범위를 선택
2. 각 셀의 값을 기준으로 시트 이름으로 사용
3. 동일한 이름이 이미 존재할 경우, "_1", "_2" 식으로 자동 구분
4. 시트는 현재 통합 문서의 마지막에 순서대로 추가

이 매크로의 장점은 단순함과 확장성입니다

- 항목이 수십 개여도 단 5초면 시트 생성 완료
- 이름 중복 자동 처리로 오류 발생 없음
- 고객 관리, 부서별 보고서, 월별 시트 생성 등에 폭넓게 활용 가능
- 응용하면 해당 시트에 표 자동 생성, 템플릿 복사 등도 가능

이 매크로가 특히 유용한 경우는?
   1. 부서별 보고서를 개별 시트로 만들 때
   2. 고객별 견적서 탭을 일괄 생성할 때
   3. 일정별 업무 시트를 날짜별로 만들 때
   4. 교육 자료나 평가표를 대상별로 생성할 때

사용 방법은 매우 간단합니다
1. 매크로 편집기(Alt + F11)에서 코드 붙여넣기
2. Excel로 돌아와 매크로 실행(Alt + F8)
   3. "시트 이름으로 사용할 셀 범위"를 선택
   4. 자동으로 새로운 시트가 만들어짐

VBA 코드

Option Explicit

Sub CreateSheetsFromRange()
    Dim rng As Range
    Dim cell As Range
    Dim wsName As String
    Dim newSheet As Worksheet
    Dim countName As Long

    ' 입력창: 시트 이름이 될 셀 범위 선택
    On Error Resume Next
    Set rng = Application.InputBox("시트 이름으로 사용할 셀 범위를 선택하세요:", _
                                   "시트 생성", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub

    Application.ScreenUpdating = False

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            wsName = CStr(cell.Value)

            ' 기존 시트와 이름이 겹치는 경우 일련번호 붙이기
            countName = 1
            Do While SheetExists(wsName)
                wsName = CStr(cell.Value) & "_" & countName
                countName = countName + 1
            Loop

            ' 시트 생성
            Set newSheet = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
            newSheet.Name = wsName
        End If
    Next cell

    Application.ScreenUpdating = True
    MsgBox "시트 생성 완료!", vbInformation
End Sub

' 시트 존재 여부 확인 함수
Private Function SheetExists(shtName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(shtName)
    SheetExists = Not ws Is Nothing
    On Error GoTo 0
End Function

초보자도 실수 없이 활용할 수 있으며
반복 작업이 많은 업무 담당자에게는 반드시 필요한 도구입니다.

정리하며
엑셀을 단순한 계산 도구가 아닌
업무 자동화 플랫폼으로 활용하고 싶다면
이런 매크로는 필수입니다.

단 몇 초면 수작업으로 1시간 걸릴 일을 대신할 수 있습니다.

엑셀 자동화에 관심 있으시다면
블로그 구독하고 실전 VBA 팁을 꾸준히 받아보세요.

감사합니다.

셀값으로 시트 생성하기.xlsm

엑셀에서 순번 넣기

노만e — Thu, 28 Aug 2025 21:06:58 +0900

엑셀에서 병합셀 포함 순번 매기기, 아직도 손으로 하나씩 하시나요?

엑셀에서 순번을 입력할 일이 많지만
병합셀이나 불규칙한 행 간격이 포함되어 있다면
단순한 자동 채우기로는 처리가 어렵습니다.

게다가 경우에 따라 아래처럼 다양한 패턴이 요구되죠:

- 구간별 리셋되는 번호
- 등차수열
- 열 방향 증가
- 병합셀 포함된 복잡한 형태

이럴 때마다 수식이나 수작업으로 처리하다 보면
시간은 오래 걸리고 실수는 잦아집니다.

그럴 때 이 엑셀 VBA 매크로 하나면 모든 상황에 대응할 수 있습니다.

엑셀 순번 매기기, 자동으로 다양한 방식으로 입력하는 매크로가 있을까요?

있습니다.
오늘 소개할 VBA 매크로는 총 **4가지 모드**를 지원하며
사용자의 선택에 따라 병합셀 포함 여부, 열 방향 또는 행 방향,
초기값 및 증분까지 지정할 수 있습니다.

기능은 다음과 같습니다:

1. **문자-리셋 모드**
    문자가 나타나면 번호를 1로 리셋하여 다시 시작
    보고서 구분 행이나 그룹별 순번에 적합

2. **구간 채우기 모드**
    시작 숫자부터 종료 숫자까지 1씩 증가하며 채우기
    예: 5부터 30까지 순차 입력

3. **등차 수열 모드**
    시작값과 증가값(공차)을 입력하여 순서대로 입력
    예: 100, 200, 300 …

4. **열 방향 증가 모드**
    좌→우, 위→아래 순서로 숫자 증가
    가로 구조 테이블, 스케줄, 좌석표에 적합

추가로, 모든 모드는 **병합 셀을 완전히 지원**하며
병합된 셀도 하나의 단위로 인식하고 해당 영역 전체에 같은 값을 채워줍니다.

코드 실행 흐름은 다음과 같습니다:

1. 사용자가 입력할 셀을 선택
2. 매크로 실행 → 모드 선택 창 출력
3. 각 모드에 따라 추가 숫자 입력 요청
4. 병합 여부, 방향, 증분 고려하여 자동 입력

예시 활용 상황:

- 시험지 문제 번호 입력
- 팀원별 업무 시트 순번 매기기
- 보고서 섹션별 자동 번호 부여
- 테이블형 좌석 배치 순번 자동화
- 수기 대장 자동 정렬 번호 입력 등

이 매크로는 특히 **셀 병합이 포함된 양식이나 보고서에 강력한 기능**을 제공합니다.

VBA 코드

Option Explicit

' ===============================================
' 다중 모드 순번/수열 입력기 (병합셀 완전 지원)
' 사용법:
'   1) 번호를 넣을 범위를 선택한다.
'   2) FillSequence_MultiMode 매크로 실행 후 모드 선택.
'
' 모드 설명
'   1) [문자-리셋 모드] : "숫자가 아닌 값"이 있는 행은 그대로 두고,
'      그 "다음 행"부터 1로 재시작하여 아래로 번호 입력
'   2) [구간 채우기] : 첫 숫자와 마지막 숫자를 입력하면, 활성 셀부터
'      아래 방향으로 1씩 증가하며 마지막 숫자까지 채움 (?Gemini 개선 코드)
'   3) [등차 수열] : 첫 숫자와 증분(증가량)을 넣어 아래로 채움
'   4) [열 방향 증가] : 선택영역을 가로로 진행하며 증가(좌→우, 위→아래)
' 공통 규칙
'   - 병합셀은 MergeArea 전체에 동일 값 입력하고 1스텝으로 간주
' ===============================================
Public Sub FillSequence_MultiMode()
    Dim selRng As Range
    Dim modeNo As Variant
    Dim startNum As Double, endNum As Double, stepNum As Double

    If TypeName(Selection) <> "Range" Then
        Set selRng = Application.InputBox("번호를 넣을 범위를 선택하세요.", "순번 입력", Type:=8)
        If selRng Is Nothing Then Exit Sub
    Else
        Set selRng = Selection
    End If

    modeNo = Application.InputBox( _
            Prompt:="모드를 선택하세요:" & vbCrLf & _
                    "1 = 문자 만나면 다음 행부터 1로 리셋 (세로)" & vbCrLf & _
                    "2 = 첫 숫자~마지막 숫자 구간 채우기 (세로)" & vbCrLf & _
                    "3 = 첫 숫자 + 증분(등차수열) (세로)" & vbCrLf & _
                    "4 = 열 방향으로 증가 (가로→세로)", _
            Title:="순번 모드 선택", Type:=1)
    If modeNo = False Then Exit Sub
    If modeNo < 1 Or modeNo > 4 Then Exit Sub

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

    Select Case CLng(modeNo)
        Case 1
            Mode1_ResetOnText selRng
        Case 2
            startNum = CDbl(Application.InputBox("첫 숫자를 입력하세요.", "구간 시작", Type:=1))
            endNum = CDbl(Application.InputBox("마지막 숫자를 입력하세요.", "구간 끝", Type:=1))
            Mode2_RangeFill selRng, startNum, endNum
        Case 3
            startNum = CDbl(Application.InputBox("첫 숫자를 입력하세요.", "초항", Type:=1))
            stepNum = CDbl(Application.InputBox("증분(등차)을 입력하세요. 예: 1, 0.5, -2", "공차", Type:=1))
            Mode3_Arithmetic selRng, startNum, stepNum
        Case 4
            startNum = CDbl(Application.InputBox("시작 숫자를 입력하세요.", "열 방향 시작값", Type:=1))
            stepNum = CDbl(Application.InputBox("증분(증가량)을 입력하세요.", "열 방향 증분", Type:=1))
            Mode4_Horizontal selRng, startNum, stepNum
    End Select

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

' =============== 모드 1 (첫 셀 기준 1씩 증가) ===============
' - 첫 셀에 값이 있으면 그 값에서 시작
' - 다음 행부터 1씩 증가
' - 글자가 있으면 번호 리셋
Private Sub Mode1_ResetOnText(ByVal rng As Range)
    Dim a As Range, ws As Worksheet
    Dim r As Long, lastRow As Long, col As Long
    Dim seq As Double
    Dim c As Range, tl As Range
    Dim initialized As Boolean

    For Each a In rng.Areas
        Set ws = a.Worksheet
        col = a.Columns(1).Column
        lastRow = a.Row + a.Rows.Count - 1
        initialized = False

        r = a.Row
        Do While r <= lastRow
            Set c = ws.Cells(r, col)

            ' 병합이면 좌상단만 사용
            If c.MergeCells Then
                Set tl = c.MergeArea.Cells(1, 1)
                If c.Address <> tl.Address Then
                    r = r + 1
                    GoTo ContinueLoop
                End If
            Else
                Set tl = c
            End If

            If HasNonNumericText(tl.Value) Then
                ' 글자가 있으면 → 다음 행부터 1로 리셋
                seq = 1
                initialized = True
            Else
                If Not initialized Then
                    ' 첫 번째 숫자 → 그대로 두고 초기화
                    If IsNumeric(tl.Value) And Not IsEmpty(tl.Value) Then
                        seq = CDbl(tl.Value) + 1
                    Else
                        ' 비어있다면 1로 시작
                        AssignValue tl, 1
                        seq = 2
                    End If
                    initialized = True
                Else
                    ' 순번 입력
                    AssignValue tl, seq
                    seq = seq + 1
                End If
            End If

            ' 병합된 경우 마지막 행으로 점프
            If tl.MergeCells Then
                r = tl.MergeArea.Row + tl.MergeArea.Rows.Count - 1
            End If
ContinueLoop:
            r = r + 1
        Loop
    Next a
End Sub

' =============== 모드 2 (선택 셀 기준, 한 행씩 +1, lastVal 포함 후 종료) ===============

Private Sub Mode2_RangeFill(ByVal rng As Range, ByVal firstVal As Double, ByVal lastVal As Double)

    ' 변수 선언

    Dim i As Long

    ' 현재 셀에 첫 번째 숫자 입력
    rng.Value = firstVal

    ' 다음 셀부터 마지막 숫자까지 1씩 증가하며 입력
    For i = 1 To (lastVal - firstVal)
        rng.Offset(i, 0).Value = firstVal + i
    Next i

End Sub

' === 병합 영역 안전 기록 헬퍼: Sub로 호출(= 사용 금지) ===
Private Sub AssignValue(ByVal topLeft As Range, ByVal v As Variant)
    If topLeft.MergeCells Then
        topLeft.MergeArea.Value = v
    Else
        topLeft.Value = v
    End If
End Sub

' =============== 모드 3 ===============
' 등차 수열 (세로) : 초항 + n*증분
Private Sub Mode3_Arithmetic(ByVal rng As Range, ByVal firstVal As Double, ByVal diff As Double)
    Dim a As Range, ws As Worksheet
    Dim r As Long, lastRow As Long, col As Long
    Dim cur As Double
    Dim c As Range, tl As Range

    For Each a In rng.Areas
        Set ws = a.Worksheet
        col = a.Columns(1).Column
        lastRow = a.Row + a.Rows.Count - 1
        cur = firstVal

        r = a.Row
        Do While r <= lastRow
            Set c = ws.Cells(r, col)
            If c.MergeCells Then
                Set tl = c.MergeArea.Cells(1, 1)
                If c.Address <> tl.Address Then
                    r = r + 1
                    GoTo ContinueLoop
                End If
            Else
                Set tl = c
            End If

            AssignValue tl, cur
            If tl.MergeCells Then
                r = tl.MergeArea.Row + tl.MergeArea.Rows.Count - 1
            End If
            cur = cur + diff
ContinueLoop:
            r = r + 1
        Loop
    Next a
End Sub

' =============== 모드 4 ===============
' 열 방향(좌→우, 위→아래) 증가
Private Sub Mode4_Horizontal(ByVal rng As Range, ByVal firstVal As Double, ByVal diff As Double)
    Dim a As Range, ws As Worksheet
    Dim r As Long, c As Long, cur As Double
    Dim topRow As Long, leftCol As Long, bottomRow As Long, rightCol As Long
    Dim cell As Range, tl As Range

    For Each a In rng.Areas
        Set ws = a.Worksheet
        topRow = a.Row: leftCol = a.Column
        bottomRow = a.Row + a.Rows.Count - 1
        rightCol = a.Column + a.Columns.Count - 1

        cur = firstVal

        For r = topRow To bottomRow
            c = leftCol
            Do While c <= rightCol
                Set cell = ws.Cells(r, c)

                ' 병합이면 좌상단만 처리하고 우/하 범위를 한 번에 건너뜀
                If cell.MergeCells Then
                    Set tl = cell.MergeArea.Cells(1, 1)
                    If cell.Address <> tl.Address Then
                        c = c + 1
                        GoTo NextCol
                    End If
                    AssignValue tl, cur
                    ' 다음 진행 위치: 병합영역의 "마지막 열 + 1"
                    c = tl.MergeArea.Column + tl.MergeArea.Columns.Count
                Else
                    AssignValue cell, cur
                    c = c + 1
                End If
                cur = cur + diff
NextCol:
            Loop
        Next r
    Next a
End Sub

' "숫자로 완전히 해석되지 않으면" 텍스트로 간주
Private Function HasNonNumericText(ByVal v As Variant) As Boolean
    Dim s As String: s = Trim$(CStr(v))
    If s = "" Then
        HasNonNumericText = False
    Else
        HasNonNumericText = Not IsNumeric(s)
    End If
End Function

Sub SelectNumericCells()
    Dim selRng As Range, c As Range
    Dim numRng As Range

    ' 선택한 범위 확인
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set selRng = ActiveSheet.UsedRange

    ' 숫자만 모으기
    For Each c In selRng.Cells
        If IsNumeric(c.Value) And Not IsEmpty(c.Value) Then
            If numRng Is Nothing Then
                Set numRng = c
            Else
                Set numRng = Union(numRng, c)
            End If
        End If
    Next c

    ' 결과 처리
    If numRng Is Nothing Then
        MsgBox "선택한 범위에 숫자가 없습니다.", vbInformation
    Else
        numRng.Select
'        numRng.Interior.Color = vbYellow   ' 숫자셀을 강조 표시
    End If
End Sub

이제 순번 입력도 자동화해보세요.

엑셀 VBA를 몰라도
이 매크로는 설명이 직관적이어서 누구나 쉽게 사용할 수 있습니다.

복잡한 순번 패턴도 이제 단 10초면 해결 가능합니다.

엑셀 자동화를 활용한 스마트 워크에 관심 있다면
지금 블로그를 구독하고 더 많은 실전 매크로를 받아보세요.

감사합니다.

셀에 순번 넣기 방법.xlsm

엑셀 두 범위, 여러 열 중복값 찾기

노만e — Wed, 27 Aug 2025 20:12:59 +0900

엑셀에서 두 범위의 중복 데이터를 빠르게 찾고 싶으신가요?

두 개의 테이블이나 시트 간 데이터를 비교하다 보면
중복되는 행이 있는지 확인하는 일이 참 번거롭습니다.
눈으로 하나씩 확인하다 보면 실수도 생기고 시간이 오래 걸립니다.

특히 수천 개의 데이터가 있는 경우라면
이 작업은 반복과 지루함의 연속일 수밖에 없죠.

그렇다면, 엑셀 매크로 한 줄로 이 문제를 해결할 수 있다면 어떨까요?

두 데이터 범위에서 중복 행을 자동으로 찾아서 색상으로 표시하는 방법은?

오늘 소개할 엑셀 VBA 매크로는
두 개의 데이터 범위를 비교하여 중복되는 행을 자동으로 탐지하고,
중복된 셀에 색상을 칠해 가시적으로 표시해주는 자동화 도구입니다.

사용자는 비교할 두 범위를 직접 마우스로 선택만 하면 되고,
머리글을 포함할지 여부도 선택할 수 있도록 설계되어 있어 유연하게 사용할 수 있습니다.

핵심 기능은 다음과 같습니다:
1. 두 범위 선택 (InputBox 방식으로 사용자가 직접 지정)
2. 머리글 제외 여부 선택 가능
3. 첫 열 기준으로 중복값 조건부 서식 적용 (빨간색 강조)
4. 전체 행이 동일할 경우, 양쪽 모두에 연한 노란색 배경 처리
5. 비교 대상이 하나의 열일 경우에도 지원됨

예: 제품 리스트 vs 발주 리스트 비교, 본사 자료 vs 지점 자료 등

중복 데이터를 찾는 실제 VBA 코드의 핵심 구조는 다음과 같습니다:
- 조건부 서식 활용으로 중복값 강조
- 다중 열 비교 시 모든 열 값이 같아야 중복으로 판단
- 비교 기준은 첫 번째 열을 기준으로 시작되며
- 결과는 자동으로 색상 적용

이 매크로의 사용 예시는 다음과 같습니다:
1. 판매 목록과 배송 목록 비교
2. 본사 마스터 파일과 각 지점 자료 비교
3. 과거 이력과 신규 등록 데이터 비교
4. 중복 등록 여부 점검

복잡한 IF나 VLOOKUP 없이,
직접 선택만으로 정확한 비교가 가능하다는 것이 이 VBA의 가장 큰 장점입니다.

VBA 코드

Option Explicit

' ===========================================
'  두 범위 중복 표시 (머릿글 제외 버전)
'  - 1) 첫 번째 범위 내부 중복: "첫 열"만 검사 (첫 행은 제외)
'  - 2) 두 범위 행 단위 완전 일치: 양쪽 모두 "같은 색"으로 강조
'  - 비교 규칙: Trim + 대소문자 무시
' ===========================================

Private Const COLOR_DUP_COL1 As Long = &H99CCFF   ' 첫 범위의 "첫 열" 중복 표시 색
Private Const COLOR_ROW_MATCH As Long = &HCCFFCC  ' r1↔r2 행 완전일치 공통 색

Public Sub Mark_Duplicates_TwoRanges_NoHeader()
    Dim r1 As Range, r2 As Range

    ' -------- 범위 선택 --------
    On Error Resume Next
    Set r1 = Application.InputBox( _
        Prompt:="① 첫 번째 범위를 선택하세요." & vbCrLf & _
                "(첫 행은 머릿글로 간주하고 제외합니다.)", _
        Title:="첫 범위 선택", Type:=8)
    On Error GoTo 0
    If r1 Is Nothing Then Exit Sub
'    r1.Interior.ColorIndex = 2

    On Error Resume Next
    Set r2 = Application.InputBox( _
        Prompt:="② 두 번째 범위를 선택하세요." & vbCrLf & _
                "취소하면 첫 범위의 첫 열 중복만 처리합니다." & vbCrLf & _
                "(여기도 첫 행은 머릿글로 제외합니다.)", _
        Title:="두 번째 범위 선택(선택)", Type:=8)
        If r2 Is Nothing Then Exit Sub
'        r2.Interior.ColorIndex = 2
    On Error GoTo 0

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ClearFill r1
    If Not r2 Is Nothing Then ClearFill r2

    ' --- 1) r1 첫 열 중복 (첫 행 제외) ---
    HighlightCol1Duplicates_NoHeader r1, COLOR_DUP_COL1

    ' --- 2) r1↔r2 행 완전 일치 (첫 행 제외, 같은 색으로) ---
    If Not r2 Is Nothing Then
        If r1.Columns.Count <> r2.Columns.Count Then
            MsgBox "두 범위의 열 개수가 달라 행 단위 비교를 건너뜁니다." & vbCrLf & _
                   "첫 범위 열 수: " & r1.Columns.Count & " / 두 번째 범위 열 수: " & r2.Columns.Count, vbInformation
        Else
            HighlightRowMatches_NoHeader r1, r2, COLOR_ROW_MATCH
        End If
    End If

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

' -------- 범위 채우기 제거 --------
Private Sub ClearFill(ByVal rng As Range)
    On Error Resume Next
    rng.Interior.Pattern = xlNone
End Sub

' -------- 첫 열 중복(머릿글 제외) --------
Private Sub HighlightCol1Duplicates_NoHeader(ByVal rng As Range, ByVal fillColor As Long)
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim r As Long, arr As Variant
    Dim key As String

    arr = rng.Value2
    If Not IsArray(arr) Then Exit Sub

    ' 집계 (2행부터 시작)
    For r = 2 To UBound(arr, 1)
        key = Normalize(arr(r, 1))
        If Len(key) > 0 Then
            If dict.Exists(key) Then
                dict(key) = dict(key) + 1
            Else
                dict.Add key, 1
            End If
        End If
    Next r

    ' 중복 표시
    For r = 2 To UBound(arr, 1)
        key = Normalize(arr(r, 1))
        If Len(key) > 0 Then
            If dict.Exists(key) And dict(key) >= 2 Then
                rng.Cells(r, 1).Interior.Color = fillColor
            End If
        End If
    Next r
End Sub

' -------- 두 범위 행 일치 (머릿글 제외) --------
Private Sub HighlightRowMatches_NoHeader(ByVal r1 As Range, ByVal r2 As Range, ByVal fillColor As Long)
    Dim dictR2 As Object: Set dictR2 = CreateObject("Scripting.Dictionary")
    Dim arr1 As Variant, arr2 As Variant
    Dim r As Long, cols As Long
    Dim key As String, delim As String

    arr1 = r1.Value2
    arr2 = r2.Value2
    cols = r1.Columns.Count
    delim = Chr$(30)

    ' r2 → Key 저장 (2행부터)
    For r = 2 To UBound(arr2, 1)
        key = BuildRowKey(arr2, r, cols, delim)
        If Len(key) > 0 Then dictR2(key) = True
    Next r

    ' r1에서 매칭 확인
    For r = 2 To UBound(arr1, 1)
        key = BuildRowKey(arr1, r, cols, delim)
        If Len(key) > 0 Then
            If dictR2.Exists(key) Then r1.Rows(r).Interior.Color = fillColor
        End If
    Next r

    ' r2에서도 매칭 확인
    For r = 2 To UBound(arr2, 1)
        key = BuildRowKey(arr2, r, cols, delim)
        If Len(key) > 0 Then
            If dictR2.Exists(key) Then r2.Rows(r).Interior.Color = fillColor
        End If
    Next r
End Sub

' -------- 행 키 만들기 --------
Private Function BuildRowKey(ByRef arr As Variant, ByVal rowIdx As Long, ByVal cols As Long, ByVal delim As String) As String
    Dim parts() As String, c As Long
    ReDim parts(1 To cols)
    For c = 1 To cols
        parts(c) = Normalize(arr(rowIdx, c))
    Next c
    BuildRowKey = Join(parts, delim)
End Function

' -------- 값 정규화 --------
Private Function Normalize(ByVal v As Variant) As String
    If IsError(v) Then
        Normalize = "#ERROR!"
    ElseIf IsEmpty(v) Or IsNull(v) Then
        Normalize = ""
    Else
        Normalize = LCase$(Trim$(CStr(v)))
    End If
End Function

엑셀 VBA가 어렵다고 느껴지시나요?

걱정하지 않으셔도 됩니다.

이 코드는 복사해서 그대로 VBA 편집기에 붙여넣기만 하면 바로 실행 가능하며,
실행 시 사용자가 범위만 지정하면 나머지는 자동으로 처리됩니다.

초보자도 실수 없이 활용할 수 있도록 안내 메시지가 포함되어 있어
엑셀 자동화 입문용으로도 최적화된 구조입니다.

정리하며
반복되는 데이터 비교 작업, 이제 수작업에서 벗어나 자동화로 전환해보세요.

단순하지만 강력한 이 매크로 한 줄로
업무 속도는 올라가고 오류는 줄어듭니다.

엑셀 자동화를 통해 실무 생산성을 높이고 싶은 분들은
지금 이 블로그를 구독해보세요.

앞으로도 실무에 바로 써먹을 수 있는 엑셀 VBA 꿀팁을 지속적으로 공유드리겠습니다.

감사합니다.

중복값 찾기.xlsm

보이는 셀에만 지점별 일련번호 입력

노만e — Tue, 26 Aug 2025 23:02:05 +0900

엑셀 필터링 후 보이는 셀에만 값을 넣고 싶을 때 어떻게 하시나요?
손으로 하나씩 입력하고 계시다면 이 글을 꼭 읽어보셔야 합니다.

엑셀에서 필터를 걸었을 때 숨겨진 행은 건너뛰고
보이는 셀에만 일련번호나 코드를 자동으로 입력하고 싶을 때가 많습니다.

특히 물류, 재고, 거래처 코드 입력 등에서는
일정한 접두어와 순차 번호가 포함된 값이 필요하죠.

엑셀에서 지점별로 자동 일련번호를 매기고 싶으셨나요?

필터로 구분된 항목마다 접두어가 다르고
일련번호도 각각 다르게 시작해야 하는 작업,
수작업으로 하면 시간도 오래 걸리고 실수도 생기기 쉽습니다.

특히 파일 리스트나 판매 내역처럼 지점 단위로
정리된 데이터를 다루는 경우엔 반복작업이 많습니다.

엑셀로 이런 문제를 자동으로 해결할 수 있다면 어떨까요?

엑셀 VBA로 지점별 자동 일련번호를 매길 수 있을까요?

가능합니다.
오늘 소개할 VBA 코드는 사용자의 선택 없이도
B열의 지점명을 기준으로 자동 필터링을 수행한 후,
각 지점별로 접두어와 함께 고유 일련번호를 매깁니다.

예를 들어
서울점은 S-01, S-02
부산점은 B-01, B-02
광주점은 G-01 형식으로 자동 생성되며,
숨겨진 행은 건너뛰기 때문에 데이터 무결성도 유지됩니다.

VBA 코드의 핵심 구조는 다음과 같습니다:

1. B열에서 지점명을 자동으로 감지
2. 각 지점별로 자동 필터 적용
3. 지점명에 따라 접두어 설정 (예: 서울점 → S)
4. 각 지점별로 고유 일련번호 시작
5. I열에 자동 입력
VBA 코드

Sub AutoFill_Serial_ByBranch_Filtered()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim branchCol As Long: branchCol = 2     ' 지점은 B열
    Dim serialCol As Long: serialCol = 7     ' 일련번호 출력은 I열
    Dim prefix As String
    Dim i As Long
    Dim serial As Long
    Dim cell As Range
    Dim branch As String
    Dim dict As Object
    Dim branchList As Collection
    Dim item As Variant

    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set branchList = New Collection

    ' 마지막 행 찾기
    lastRow = ws.Cells(ws.Rows.Count, branchCol).End(xlUp).Row

    ' B열(지점명)에서 고유값 수집
    For i = 2 To lastRow
        branch = ws.Cells(i, branchCol).Value
        If branch <> "" Then
            If Not dict.exists(branch) Then
                dict.Add branch, True
                branchList.Add branch
            End If
        End If
    Next i

    Application.ScreenUpdating = False

    ' 고유 지점명 순회하면서 자동 필터 및 일련번호 삽입
    For Each item In branchList
        ' 필터 적용
        ws.Range("A1").AutoFilter Field:=branchCol, Criteria1:=item

        ' 접두어 결정
        Select Case item
            Case "서울점": prefix = "S"
            Case "부산점": prefix = "B"
            Case "대전점": prefix = "D"
            Case "광주점": prefix = "G"
            Case "대구점": prefix = "T"
            Case Else: prefix = "X"
        End Select

        serial = 1

        ' 보이는 셀만 처리
        For i = 2 To lastRow
            If Not ws.Rows(i).Hidden Then
                ws.Cells(i, serialCol).Value = prefix & "-" & Format(serial, "00")
                serial = serial + 1
            End If
        Next i
    Next item

    ' 필터 해제
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True

    MsgBox "일련번호 자동 입력이 완료되었습니다."
End Sub

실행 방법도 간단합니다
1. Alt + F11 → 새 모듈 삽입 후 코드 붙여넣기
2. Alt + F8 → 매크로 선택 후 실행
3. 결과는 자동으로 I열에 입력됨

파일 리스트에 하이퍼링크를 자동으로 연결할 수 있을까요?

네. 이 코드를 확장하면
파일 리스트를 자동으로 불러오고
각 파일에 하이퍼링크까지 연결하는 매크로도 쉽게 제작할 수 있습니다.

예를 들어 보고서 파일명을 리스트업하고
각 파일명을 클릭하면 자동으로 파일이 열리는 구조를 만들 수 있습니다.

이런 방식은
1. 팀원들과 공유할 때
2. 폴더에 파일이 자주 추가되는 경우
3. 버전별 문서를 관리할 때 매우 효과적입니다.

엑셀 VBA는 단순 반복 작업을 줄이고
실무 속도를 압도적으로 끌어올려줍니다.

지금 이 코드부터 실무에 도입해보세요.

오늘 소개한 매크로는
데이터 관리, 판매 내역 정리, 코드 생성 등
다양한 작업에 실질적인 도움이 될 수 있습니다.

앞으로도 이런 자동화 팁이 더 궁금하시다면
블로그 구독과 알림 설정을 통해
빠르게 받아보세요.

엑셀을 진짜 업무 도구로 바꾸는 가장 쉬운 방법,
지금 이 글에서 시작해보세요.

감사합니다.

지점별 일련번호 넣기.xlsm

엑셀 VBA 꿀팁 모음 – 행 삽입, 빈 행 삭제, 값 채우기, 자동 범위 선택 정리

노만e — Mon, 25 Aug 2025 22:25:14 +0900

엑셀에서 반복적으로 수행하는 작업을 VBA 매크로로 자동화하면 업무 효율이 크게 올라갑니다.
이번 글에서는 행 삽입 및 값 채우기, 빈 행 삭제, 현재 셀 기준 자동 범위 선택까지, 실무에서 꼭 필요한 VBA 코드를 한곳에 모아 정리했습니다.

1️⃣ 선택 범위 사이에 행 삽입 매크로

기능

선택한 범위 내 각 인접 행 사이에, 입력받은 개수(n)만큼 빈 행을 삽입합니다.
삽입할 행 개수를 사용자에게 InputBox로 입력받습니다.

코드

Option Explicit

' 선택한 범위(여러 영역 가능)의 "각 인접 행 사이"에
' 사용자에게 입력받은 개수(n)만큼 행을 삽입합니다.
Public Sub InsertRowsBetweenSelection()
    Dim n As Long, ans As Variant
    Dim ws As Worksheet
    Dim ar As Range
    Dim firstRow As Long, lastRow As Long
    Dim r As Long
    Dim rowsToProcess() As Long
    Dim cnt As Long

    If TypeName(Selection) = "Nothing" Then Exit Sub
    If Selection.Rows.Count = 0 Then Exit Sub

    ' 1) 삽입 행 수 입력
    ans = Application.InputBox( _
            Prompt:="사이에 넣을 행의 개수를 입력하세요 (정수, 1 이상):", _
            Title:="행 삽입", Type:=1) ' 숫자만
    If ans = False Then Exit Sub  ' 사용자가 취소
    If CLng(ans) < 1 Then Exit Sub
    n = CLng(ans)

    Set ws = ActiveSheet

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' 2) 각 영역 별로 처리
    For Each ar In Selection.Areas
        ' 영역의 첫/끝 행
        firstRow = ar.Rows(1).Row
        lastRow = ar.Rows(ar.Rows.Count).Row

        ' 영역 내 "사이"가 없으면 스킵 (행이 1줄뿐인 영역)
        If lastRow - firstRow < 1 Then GoTo NextArea

        ' 3) 삽입 기준이 되는 "아래에서 위로" 행 인덱스 목록 만들기
        '    예: 5~10행 선택이면 9,8,7,6,5 순으로 삽입 위치를 잡음
        cnt = 0
        Erase rowsToProcess
        For r = lastRow - 1 To firstRow Step -1
            cnt = cnt + 1
            ReDim Preserve rowsToProcess(1 To cnt)
            rowsToProcess(cnt) = r
        Next r

        ' 4) 실제 삽입 (각 r의 "아래"에 n행 삽입)
        For r = 1 To cnt
            ws.Rows(rowsToProcess(r) + 1).Resize(n).Insert Shift:=xlDown
            ' 필요 시 서식 기준 지정(신형 엑셀):
            ' ws.Rows(rowsToProcess(r) + 1).Resize(n).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Next r

NextArea:
    Next ar

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

사용 방법

행 삽입이 필요한 범위를 선택합니다.
매크로 실행 시 팝업창에 삽입할 행의 개수를 입력합니다.
선택한 범위 사이사이에 지정한 수 만큼 행이 들어갑니다.

2️⃣ 선택 범위 내 빈 행 삭제 매크로

기능

선택된 범위에서 완전히 빈 행만 찾아 삭제합니다.
삭제된 행 개수를 메시지로 알려줍니다.

코드

' 선택된 범위 내에서 "완전히 빈 행"을 찾아 삭제합니다.
' (삭제 직전에 개수를 저장하여 424 오류 방지)
Public Sub DeleteEmptyRowsInSelection()
    Dim rng As Range, r As Range
    Dim delRows As Range
    Dim ws As Worksheet
    Dim deletedCount As Long   ' ← 삭제 전 개수 저장용

    If TypeName(Selection) = "Nothing" Then Exit Sub
    If Selection.Rows.Count = 0 Then Exit Sub

    Set ws = ActiveSheet
    Set rng = Selection

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' 아래에서 위로 확인하면서 빈 행 수집
    For Each r In rng.Rows
        If Application.CountA(r) = 0 Then
            If delRows Is Nothing Then
                Set delRows = r
            Else
                Set delRows = Union(delRows, r)
            End If
        End If
    Next r

    ' 삭제 + 메시지
    If Not delRows Is Nothing Then
        deletedCount = delRows.Rows.Count   ' ← 삭제 전에 개수 확보
        delRows.Delete Shift:=xlUp          ' 선택 범위 안에서만 위로 당김
        MsgBox "빈 행이 삭제되었습니다.", vbInformation
    Else
        MsgBox "선택한 범위에는 빈 행이 없습니다.", vbInformation
    End If

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

사용 방법

빈 행이 포함된 영역을 드래그하여 선택합니다.
매크로 실행 → 빈 행이 모두 삭제됩니다.

3️⃣ 행 삽입 + 값 자동 채우기 + 마지막 행 복제

기능

선택 범위의 각 인접 행 사이에 행 삽입
삽입된 행을 바로 위 행의 값으로 자동 채움
선택 영역의 마지막 행 아래에도 추가로 n행 삽입 후, 마지막 행 값으로 채워줍니다.

코드

' 선택한 범위(여러 영역 가능)의 "각 인접 행 사이"에
' 사용자에게 입력받은 개수(n)만큼 행을 삽입하고,
' 삽입된 행은 "바로 위 행의 값"으로 채우며,
' 각 영역의 "맨 마지막 행 아래"에도 n개 행을 추가로 삽입해 마지막 행의 값으로 채웁니다.
Public Sub InsertRowsBetweenSelection_FillFromAbove_AppendBottom()
    Dim n As Long, ans As Variant
    Dim ws As Worksheet
    Dim ar As Range
    Dim firstRow As Long, lastRow As Long
    Dim areaFirstCol As Long, areaLastCol As Long
    Dim r As Long, k As Long
    Dim rowsToProcess() As Long
    Dim cnt As Long, pairs As Long, idx As Long
    Dim src As Variant, srcBottom As Variant
    Dim currentBottom As Long, insertStart As Long

    If TypeName(Selection) = "Nothing" Then Exit Sub
    If Selection.Rows.Count = 0 Then Exit Sub

    ' 1) 삽입 행 수 입력
    ans = Application.InputBox( _
            Prompt:="사이에 넣을 행의 개수를 입력하세요 (정수, 1 이상):", _
            Title:="행 삽입", Type:=1) ' 숫자만
    If ans = False Then Exit Sub
    If CLng(ans) < 1 Then Exit Sub
    n = CLng(ans)

    Set ws = ActiveSheet

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' 2) 각 영역 별로 처리
    For Each ar In Selection.Areas
        firstRow = ar.Rows(1).Row
        lastRow = ar.Rows(ar.Rows.Count).Row
        areaFirstCol = ar.Columns(1).Column
        areaLastCol = ar.Columns(ar.Columns.Count).Column

        ' 미리 "영역의 마지막 행 값"을 확보 (맨 아래 추가용)
        srcBottom = ws.Range(ws.Cells(lastRow, areaFirstCol), _
                             ws.Cells(lastRow, areaLastCol)).Value

        ' --- 사이 삽입 (아래→위) ---
        pairs = Application.Max(0, lastRow - firstRow) ' 인접 구간 수
        If pairs > 0 Then
            cnt = 0
            Erase rowsToProcess
            For r = lastRow - 1 To firstRow Step -1
                cnt = cnt + 1
                ReDim Preserve rowsToProcess(1 To cnt)
                rowsToProcess(cnt) = r
            Next r

            For idx = 1 To cnt
                ' (1) r 아래에 n행 삽입
                ws.Rows(rowsToProcess(idx) + 1).Resize(n).Insert Shift:=xlDown
                ' 필요 시: CopyOrigin:=xlFormatFromLeftOrAbove

                ' (2) r(원본)의 값을 가져와 삽입된 각 행에 "값" 채우기
                src = ws.Range(ws.Cells(rowsToProcess(idx), areaFirstCol), _
                               ws.Cells(rowsToProcess(idx), areaLastCol)).Value
                For k = 1 To n
                    ws.Range(ws.Cells(rowsToProcess(idx) + k, areaFirstCol), _
                             ws.Cells(rowsToProcess(idx) + k, areaLastCol)).Value = src
                Next k
            Next idx
        End If

        ' --- 맨 아래 추가 삽입 ---
        ' 사이 삽입으로 마지막 행이 아래로 내려갔으므로 현재 마지막 행 위치를 계산
        currentBottom = lastRow + pairs * n
        insertStart = currentBottom + 1

        ' n행 삽입 후, "원래 마지막 행 값"으로 채움
        ws.Rows(insertStart).Resize(n).Insert Shift:=xlDown
        For k = 0 To n - 1
            ws.Range(ws.Cells(insertStart + k, areaFirstCol), _
                     ws.Cells(insertStart + k, areaLastCol)).Value = srcBottom
        Next k
    Next ar

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

사용 방법

데이터가 있는 범위를 선택합니다.
매크로 실행 후 삽입할 행 수를 입력합니다.
선택 영역 사이와 마지막 행 아래에 행이 추가되며, 값이 자동 복제됩니다.

4️⃣ 현재 셀 기준으로 범위 자동 선택

기능

현재 활성 셀을 기준으로 같은 행의 마지막 열과 같은 열의 마지막 행을 찾습니다.
이 두 지점을 기준으로 직사각형 범위를 자동 선택합니다.

코드

' 현재셀 기준으로
'   → 같은 행의 마지막 사용 열
'   → 같은 열의 마지막 사용 행
' 두 점을 잡아 직사각형 범위를 선택
Public Sub SelectRangeFromCurrentCell()
    Dim ws As Worksheet
    Dim startRow As Long, startCol As Long
    Dim lastRow As Long, lastCol As Long

    Set ws = ActiveSheet

    startRow = ActiveCell.Row
    startCol = ActiveCell.Column

    ' 현재 행에서 마지막 사용 열 찾기
    lastCol = ws.Cells(startRow, ws.Columns.Count).End(xlToLeft).Column

    ' 현재 열에서 마지막 사용 행 찾기
    lastRow = ws.Cells(ws.Rows.Count, startCol).End(xlUp).Row

    ' 직사각형 범위 선택
    ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastRow, lastCol)).Select
End Sub

사용 방법

범위의 시작이 될 셀을 클릭합니다.
매크로 실행 → 현재 셀에서 마지막 데이터까지 자동으로 범위가 선택됩니다.

⚠️ 주의사항

VBA 코드는 반드시 개발 도구 > VBA 편집기에서 해당 시트 모듈 또는 표준 모듈에 넣어야 실행됩니다.
ActiveCell을 사용하는 매크로는 반드시 현재 선택 셀을 확인 후 실행하세요.
Application.EnableEvents와 ScreenUpdating을 꺼두는 구문이 있으므로, 예상치 못한 상황에서는 매크로 중간 종료 시 이벤트가 꺼질 수 있습니다. → 그럴 땐 즉시창에서 Application.EnableEvents = True 입력.

✅ 마무리 (CTA)

엑셀에서 반복 작업 때문에 시간을 허비하지 마세요.
위의 VBA 매크로들을 활용하면 행 삽입, 삭제, 값 채우기, 자동 범위 선택까지 클릭 한 번으로 끝낼 수 있습니다.

더 많은 엑셀 VBA 꿀팁과 자동화 코드를 받아보고 싶다면 블로그 이웃추가 + 구독 눌러주세요.

작은 자동화가 루루님의 시간을 크게 절약해 드릴 거예요

행삽입 및 값 채워넣기_ver1.0.xlsm

파일리스트 가져오기 및 하이퍼링크 연결.xlsm

엑셀 파일목록 가져오기 및 하이퍼링크 연결까지 5초안에 해결하기

노만e — Sun, 24 Aug 2025 13:30:01 +0900

1. 필요한 이유

엑셀에서 수작업으로 파일 하이퍼링크를 하나하나 하고 계신가요?

업무 중 자주 쓰이는 폴더의 파일 리스트를 자동으로 불러오고,

클릭 한 번으로 파일을 열 수 있다면 얼마나 편리할까요?

저는 회사에서 고급필터를 이용해 수많은 컨베이어 벨트를 검색하고,

해당 컨베이어 벨트의 pdf도면, 지도(SCADA), 관련 정보, 자재의 재고까지

하이퍼링크로 연결하여 바로 열어 확인 할 수 있도록 만들어 놓았습니다.

특히 수백 개의 파일을 정리해야 하는 사무직, 교육업, 프리랜서 분들에게는

업무 효율을 극대화할 수 있는 해결책이 됩니다.

바로 '엑셀 VBA를 활용한 파일 리스트 자동화 및 하이퍼링크 연결'입니다.
엑셀을 단순 데이터 관리 도구가 아닌, 자동화 솔루션으로 바꿔보세요.

엑셀 VBA로 파일 리스트를 자동으로 불러오는 방법이 있을까요?
가능합니다. 엑셀의 VBA(Visual Basic for Applications)를 이용하면
특정 폴더 안의 파일 이름, 경로, 생성일 등을 자동으로 불러올 수 있고
각 항목에 하이퍼링크까지 연결해 클릭만으로 파일을 열 수 있도록 만들 수 있습니다.

핵심 코드는 다음과 같은 구조로 구성됩니다:
1. 특정 폴더 경로 설정
2. 파일 목록을 순회하며 파일명과 경로 수집
3. 수집한 정보를 셀에 출력
4. 셀에 하이퍼링크 설정

예를 들어 아래와 같은 VBA 코드를 사용하면
D 드라이브 안의 '보고서' 폴더에 있는 모든 엑셀 파일의 리스트와
그에 대한 하이퍼링크를 엑셀 시트에 자동으로 출력할 수 있습니다.

2. VBA 코드

Option Explicit   ' 변수 선언을 강제하여 실수를 줄임

' 메인 프로시저
Public Sub ListFiles_FromSelection_Recursive_Option()
    Dim fd As FileDialog          ' 폴더 선택 창 객체
    Dim selPath As String         ' 선택한 폴더 경로
    Dim ws As Worksheet           ' 실행할 워크시트
    Dim anchor As Range           ' 시작 셀(출력 시작 위치)
    Dim startRow As Long, startCol As Long  ' 시작 행/열 번호
    Dim nextRow As Long, lastRow As Long
    Dim n As Long                 ' 순번 번호 (No.)
    Dim excludeDetails As Boolean ' 확장자/경로 제외 여부
    Dim resp As VbMsgBoxResult    ' 메시지 박스 결과 저장
    Dim lastColOffset As Long
    Dim rngAll As Range

    ' 성능 최적화 (화면 깜빡임 방지, 계산 중지)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set ws = ActiveSheet


    ' 출력 시작 위치를 InputBox로 직접 선택
    Set anchor = ws.Range("A1")
    If anchor Is Nothing Then
        MsgBox "취소(ESC)버튼을 누르셨습니다."
        Exit Sub

    End If
    startRow = anchor.Row
    startCol = anchor.Column

        ws.Cells(startRow, startCol).CurrentRegion.Clear

    ' 확장자/경로 제외 여부를 묻는 메시지 박스
    resp = MsgBox( _
        "확장자와 경로를 제외할까요?" & vbCrLf & vbCrLf & _
        "예 : 순번 / 파일명(하이퍼링크)만 출력" & vbCrLf & _
        "아니오 : 순번 / 파일명(하이퍼링크) / 확장자 / 경로 출력", _
        vbQuestion + vbYesNo, "열 구성 옵션")
    excludeDetails = (resp = vbYes)

    ' 헤더 출력
    With ws
        .Cells(startRow, startCol + 0).Value = "No."        ' 순번
        .Cells(startRow, startCol + 1).Value = "파일명"     ' 파일명
        If Not excludeDetails Then
            .Cells(startRow, startCol + 2).Value = "확장자" ' 확장자
            .Cells(startRow, startCol + 3).Value = "경로"   ' 경로
        End If

        ' 헤더 스타일 (굵게 + 배경색 회색)
        Dim headerLastCol As Long
        headerLastCol = startCol + IIf(excludeDetails, 1, 3)
        .Range(.Cells(startRow, startCol), .Cells(startRow, headerLastCol)).Font.Bold = True
        .Range(.Cells(startRow, startCol), .Cells(startRow, headerLastCol)).Interior.Color = RGB(242, 242, 242)
    End With

    ' 폴더 선택 창 띄우기
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "가져올 폴더를 선택하세요"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo TidyExit   ' 취소 시 종료
        selPath = .SelectedItems(1)         ' 선택한 경로 저장
    End With

    ' 실제 파일 목록 채우기
    nextRow = startRow + 1
    n = 1
    Call TraverseFolderAndWrite_ToSelection_Option(selPath, ws, nextRow, startCol, n, excludeDetails)

    ' --- 출력 후 마감 처리 ---
    lastRow = nextRow - 1
    If lastRow >= startRow Then
        lastColOffset = IIf(excludeDetails, 1, 3)

        ' 열 너비 자동 맞춤
        ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastRow, startCol + lastColOffset)).Columns.AutoFit

        ' 줄무늬 효과 (홀수행 은은한 배경)
        If lastRow > startRow Then
            Dim rngBody As Range
            Set rngBody = ws.Range(ws.Cells(startRow + 1, startCol), ws.Cells(lastRow, startCol + lastColOffset))
            With rngBody.FormatConditions.Add(Type:=xlExpression, _
                Formula1:="=MOD(ROW()-" & startRow & ",2)=1")
                .Interior.Color = RGB(248, 248, 248)
            End With
        End If

        ' 테두리 적용
        Set rngAll = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastRow, startCol + lastColOffset))
        Call ApplyPrettyBorders(rngAll)
    End If

TidyExit:
    ' 최적화 원상 복구
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

' -----------------------------------------------------------
' 파일과 하위 폴더까지 모두 탐색해서 목록을 출력하는 재귀 프로시저
' -----------------------------------------------------------
Private Sub TraverseFolderAndWrite_ToSelection_Option( _
    ByVal folderPath As String, _
    ByVal ws As Worksheet, _
    ByRef nextRow As Long, _
    ByVal startCol As Long, _
    ByRef n As Long, _
    ByVal excludeDetails As Boolean)

    Dim fso As Object                ' FileSystemObject (파일/폴더 관리)
    Dim fldr As Object               ' 현재 폴더
    Dim subFldr As Object            ' 하위 폴더
    Dim fil As Object                ' 개별 파일
    Dim baseName As String           ' 확장자 제외 파일명
    Dim extName As String            ' 확장자
    Dim fullPath As String           ' 전체 경로
    Dim parentPath As String         ' 폴더 경로
    Dim cellB As Range

    On Error GoTo SafeExit
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder(folderPath)

    ' 현재 폴더의 파일 나열
    For Each fil In fldr.Files
        fullPath = fil.Path
        ' ~$ 로 시작하는 임시파일은 제외
        If Not Left$(fso.GetFileName(fullPath), 2) = "~$" Then
            baseName = fso.GetBaseName(fullPath)
            extName = fso.GetExtensionName(fullPath)
            parentPath = fso.GetParentFolderName(fullPath)

            ' A열 = 순번
            ws.Cells(nextRow, startCol + 0).Value = n

            ' B열 = 파일명 (하이퍼링크 적용)
            Set cellB = ws.Cells(nextRow, startCol + 1)
            ws.Hyperlinks.Add anchor:=cellB, Address:=fullPath, _
                               SubAddress:="", TextToDisplay:=baseName

            ' 확장자/경로 포함 여부에 따라 출력
            If Not excludeDetails Then
                ws.Cells(nextRow, startCol + 2).Value = extName
                ws.Cells(nextRow, startCol + 3).Value = parentPath
            End If

            n = n + 1
            nextRow = nextRow + 1
        End If
    Next fil

    ' 하위 폴더도 재귀적으로 탐색
    For Each subFldr In fldr.SubFolders
        Call TraverseFolderAndWrite_ToSelection_Option(subFldr.Path, ws, nextRow, startCol, n, excludeDetails)
    Next subFldr

SafeExit:
    On Error Resume Next
    Set subFldr = Nothing
    Set fldr = Nothing
    Set fso = Nothing
End Sub

' -----------------------------------------------------------
' 보기 좋은 테두리 스타일 적용
' -----------------------------------------------------------
Private Sub ApplyPrettyBorders(ByVal rng As Range)
    rng.HorizontalAlignment = xlCenter
    With rng.Borders
        .LineStyle = xlContinuous
        .Color = RGB(200, 200, 200)   ' 연한 회색
        .Weight = xlThin              ' 얇은 선
    End With

    ' 외곽선은 조금 더 두껍게
    With rng.Borders(xlEdgeLeft):   .Weight = xlMedium: End With
    With rng.Borders(xlEdgeRight):  .Weight = xlMedium: End With
    With rng.Borders(xlEdgeTop):    .Weight = xlMedium: End With
    With rng.Borders(xlEdgeBottom): .Weight = xlMedium: End With
End Sub

3. 실행 방법

실행 방법 은 간단합니다. Alt + F11을 눌러 VBA 편집기를 열고
새 모듈에 위 코드를 붙여넣은 후 실행만 하면 됩니다.

아니면, 아래 파일을 다운로드 하여 사용하세요.

하이퍼링크를 직접 걸 필요 없이 자동으로 연결되기 때문에
반복 작업이 많을수록 업무 효율이 기하급수적으로 증가합니다.

파일 목록 관리를 자동화하면 어떤 점이 좋을까요?

1. 문서 정리 속도 향상
2. 파일 누락 방지
3. 팀원 간 파일 공유 용이
4. 실수로 인한 오작업 최소화

특히 교육 자료, 회의록, 보고서, 견적서처럼
버전 관리가 중요한 업무에 매우 효과적입니다.

또한 이런 자동화 매크로는 필요에 따라 PDF, Word, 이미지 파일로 확장도 가능합니다.

엑셀 VBA를 처음 접하는 분들도
위와 같은 간단한 구조부터 시작하면 금방 익힐 수 있으며
점차 자신만의 자동화 시스템으로 발전시킬 수 있습니다.

지금 바로 실무에 적용해보세요. 단순 반복 업무가 놀라운 자동화로 바뀔 수 있습니다.

엑셀 VBA로 효율을 높이고 싶은 분이라면
앞으로도 다양한 자동화 팁을 받아보세요.

블로그 구독과 알림 설정은 효율적인 일처리의 시작입니다.

함께 더 똑똑한 업무 환경을 만들어보세요.

엑셀 선택셀 강조, 하이라이트

노만e — Sat, 23 Aug 2025 05:25:48 +0900

가로+세로 동시 강조로 대용량 시트에서도 실수 0에 가깝게

왜 필요한가? (Pain → Gain)

스크롤 지옥: 열이 10개, 20개 넘어가면 가로로 조금만 스크롤해도 내가 보고 있던 행·열의 기준점을 잃기 쉽습니다.
눈이 먼저 피곤: 머리로 좌표를 계속 맞추려다 보니 피로도↑, 속도↓, 오입력↑.
필터/정렬 후 검증 어려움: 필터링된 상태에서 특정 셀의 **가로줄(행)과 세로줄(열)**을 함께 보지 않으면 맥락 파악이 번번이 틀어집니다.

해결책: 선택한 셀을 기준으로 ‘가로줄 + 세로줄’을 동시에 연노랑으로 칠해 십자가 모양을 만들어 시선을 안내합니다.
행과 열이 한눈에 잡히니, 타이핑 실수·참조 실수·검증 시간이 드라마틱하게 줄어듭니다.

무엇이 달라지나? (효과)

즉시 맥락 파악: 선택 셀의 행 전체 + 열 전체가 함께 강조 → 좌표를 외우지 않아도 됩니다.
정확도 향상: SKU, 코드, 금액, 날짜 등 옆·위 데이터 매칭 실수가 크게 줄어듭니다.
속도 개선: 셀 이동만 해도 실시간으로 하이라이트가 따라옴 → 검수/입력 속도↑
집중 유지: 복잡한 표일수록 시선 분산을 줄이고 뇌 부하를 낮춤.

기능 요약

선택한 셀 기준 행 전체(연노랑) + 열 전체(하늘색) 강조(십자가).
선택 셀 자체는 더 분홍색으로 강조(선택점이 또렷).
데이터 영역 안에서만 색칠(헤더/바깥 영역은 제외 가능).
다중 선택 시 자동 비활성화(혼란 방지).
빠른 동작: 지난 강조만 지우고 새로 칠해 대용량에서도 부드럽게.

설치·사용법 (Alt+F11로 바로 적용)

Alt + F11 → VBA 편집기 열기
프로젝트 탐색기에서 하이라이트를 적용할 워크시트(예: Sheet1 등) 더블클릭
아래 코드를 그 워크시트 코드창에 붙여넣기
엑셀로 돌아와 셀을 클릭해 동작 확인

'========================================
' 선택 셀 기준 "십자가(행+열)" 하이라이트 (빠르고 깔끔한 버전)
' - 데이터 테이블 기준점 : A3 기준 CurrentRegion
' - 헤더 2행, 왼쪽 1열은 제외해 데이터영역만 칠함
' - 선택 셀 : 핑크색, 행 : 연노랑, 열 : 하늘색
'========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo SafeExit
    If Target.CountLarge > 1 Then Exit Sub          '다중 선택 시 동작 안 함

    Application.EnableEvents = False

    Dim base As Range, rTable As Range
    Dim t As Range, rowR As Range, colR As Range

    ' 1) 데이터 영역 정의 (필요 시 A1, 오프셋/리사이즈 값을 바꿔 쓰세요)
    Set base = Me.Range("A1").CurrentRegion
    Set rTable = base.Offset(1).Resize(base.Rows.Count - 1)

    ' 2) 이전 하이라이트 제거
     ActiveSheet.UsedRange.Offset(1).Interior.ColorIndex = xlNone  ' 기존 색 지우기

    ' 3) 현재 타깃(다중 선택 대비: 첫 셀만 사용)
    Set t = Target.Cells(1, 1)

    ' 4) 행/열 교차 범위 계산
    Set rowR = Intersect(rTable, t.EntireRow)
    Set colR = Intersect(rTable, t.EntireColumn)

    ' 5) 색칠: 연노랑(행), 하/열), 진한 노랑(선택 셀)
    If Not rowR Is Nothing Then rowR.Interior.ColorIndex = 36   '연노랑
    If Not colR Is Nothing Then colR.Interior.ColorIndex = 34   '하늘색
    If Not Intersect(rTable, t) Is Nothing Then
        t.Interior.ColorIndex = 38                              '핑크색(선택점)
    End If

SafeExit:
    Application.EnableEvents = True
End Sub

엑셀VBA 선택셀 강조.xlsm

보이는 셀만 복사 붙여넣기_ver1.1.xlam

추가기능 단축키로 엑셀 화면에 보이는 셀만 복사 붙여넣기

노만e — Thu, 21 Aug 2025 23:01:11 +0900

자동필터 보이는 셀만 “원클릭 복사→원하는 열에 붙여넣기”

왜 이 애드인이 실무에서 꼭 필요할까요?

필터 걸린 목록에서 보이는 셀만 골라 복사·붙여넣기… 매번 손으로 하면 실수도 나고 시간이 줄줄 새죠.
이 애드인은 그 과정을 단축키 2개로 끝냅니다.

Ctrl+Shift+C: 현재 선택(단일/다열)의 보이는 행만 내부 버퍼에 복사 + 개미행진 표시
Ctrl+Shift+V: 클릭해 둔 셀의 열부터 연속 열로 깔끔하게 값만 붙여넣기
다열 지원: B:D를 복사했다면, 붙여넣기는 클릭한 열부터 3열이 한 번에 들어감
안전장치: 소스·대상에 병합 셀이 하나라도 있으면 조용히 중단(데이터 꼬임 방지)
무음·무팝업: 작업 흐름 끊기지 않음
선택 안 했을 때: C열의 2행~끝을 기본 범위로 사용

무엇을 할 수 있나요? (기능 요약)

자동필터/표(Filter/ListObject) 환경에서 보이는 행만 정확히 집계
다열 선택 후 복사 → 연속 열 붙여넣기 자동 계산
값만 이동(서식은 그대로 유지)
복사 모드는 버퍼가 유지되어 원하는 위치에 여러 번 붙여넣기 가능
Application.CutCopyMode = xlCopy 상태 유지 → 개미행진으로 복사 영역 시각화

설치 방법(애드인 .xlam)

엑셀에서 Alt + F11 → 삽입 ▸ 모듈에 제공 코드 전부 붙여넣기
파일을 Excel 애드인(.xlam) 으로 저장
엑셀 파일 ▸ 옵션 ▸ 추가 기능 ▸ Excel 추가 기능 ▸ 이동 → 방금 .xlam 체크
이제부터
- Ctrl+Shift+C = 보이는 행만 복사(단일/다열)
- Ctrl+Shift+V = 클릭한 셀의 열부터 연속 열로 값 붙여넣기

보이는 셀만 복사 붙여넣기_ver1.1.xlam

사용 방법 (핵심 시나리오)

복사 준비

필터를 적용하고, 붙여넣고 싶은 원본 열(들) 을 선택
- 예) B:D 선택 → 보이는 행의 B,C,D만 수집
선택을 생략하면 C열(2행~끝)을 기본 사용

복사 실행

Ctrl+Shift+C → 보이는 행만 내부 버퍼 저장 + 개미행진 표시

붙여넣기 위치 지정

붙여넣기를 시작할 한 셀을 클릭(예: G5)
선택한 열이 3개였다면 G:H:I에 순서대로 들어감

붙여넣기 실행

Ctrl+Shift+V → 값만 붙습니다
복사 모드이므로 다른 열에도 계속 붙여넣기 가능

사용 팁

병합 셀 금지: 소스·대상 중 하나라도 병합이면 동작을 멈춥니다(데이터 보호).
열 오버런 보호: 붙여넣기가 XFD를 넘기면 자동 중단.
값만 붙임: 서식 동기화가 필요하면 별도 옵션 버전으로 확장 가능합니다(요청 주시면 바로 확장해 드릴게요).

엑셀문서 올인원 다이어트_ver1.2.xlsm

엑셀 파일 안 열릴때, 무거울 때? 10초 만에 다이어트! 파일 용량 확 줄이기

노만e — Tue, 19 Aug 2025 22:38:14 +0900

엑셀 무거울 땐? 원클릭 VBA 매크로로 10초 만에 다이어트!

1. 기능 소개

엑셀 파일을 열때, 20초 이상 걸리거나, 안 열릴때, 다운되거나, 마우스가 천천히 움직일때,

이 매크로 하나면 복잡하고 무거워진 엑셀 파일을 단번에 다이어트 할 수 있습니다.
실행 시 아래 작업을 선택적으로 수행합니다:

✅ 불필요한 사용자 정의 스타일 삭제 (깨끗한 서식 유지)
✅ 깨진 이름 정의(#REF!) 자동 삭제
✅ 사진은 보존하면서 모든 도형·개체 싹 정리 (AllShapeDelete 적용)
✅ 외부 연결 링크 끊기 (불필요한 링크 제거)
✅ 이미지 크기 최적화 & 압축

파일 용량이 줄고 속도도 빨라져서 실무에서 바로 효과 체감할 수 있습니다.

2. 사용 방법

Alt + F11 → VBA 편집기 열기
새 모듈에 코드 붙여넣기
엑셀파일최적화 매크로 실행
단계별로 예/아니오 선택하여 최적화 항목 결정
완료 후 최적화 결과와 소요 시간이 메시지로 표시됨

3. 코드

Option Explicit

'===============================
' 엑셀 파일 최적화 (정리된 최종본)
' - 스타일 삭제
' - 오류난 이름 삭제
' - 사진을 제외한 개체/도형 일괄 정리(AllShapeDelete 실행)
' - 외부 링크 삭제
' - 이미지 압축
'===============================

Public Sub 엑셀파일최적화()
    Dim response As VbMsgBoxResult
    Dim totalDeleted As Long
    Dim startTime As Double
    Dim endTime As Double

    startTime = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' 사용자 확인
    response = MsgBox("엑셀 파일 최적화를 시작하시겠습니까?" & vbCrLf & vbCrLf & _
                      "다음 작업이 수행됩니다:" & vbCrLf & _
                      "? 스타일 삭제" & vbCrLf & _
                      "? 오류난 이름 삭제" & vbCrLf & _
                      "? 사진을 제외한 개체/도형 정리(AllShapeDelete)" & vbCrLf & _
                      "? 외부 연결링크 삭제" & vbCrLf & _
                      "? 이미지 압축", _
                      vbYesNo + vbQuestion, "파일 최적화")

    If response = vbNo Then GoTo 정리

    On Error GoTo ErrorHandler

    ' 1. 스타일 삭제
    response = MsgBox("1. 사용자 정의 스타일을 삭제하시겠습니까?", vbYesNo + vbQuestion, "스타일 삭제")
    If response = vbYes Then
        Call 스타일삭제
        MsgBox "사용자 정의 스타일이 삭제되었습니다.", vbInformation
    End If

    ' 2. 오류난 이름 삭제
    response = MsgBox("2. 오류가 있는 이름 정의를 삭제하시겠습니까?", vbYesNo + vbQuestion, "이름 정의 삭제")
    If response = vbYes Then
        totalDeleted = 오류이름삭제()
        MsgBox totalDeleted & "개의 오류 이름이 삭제되었습니다.", vbInformation
    End If

    ' 3. 사진 제외 개체/도형 일괄 정리 → AllShapeDelete 실행
    response = MsgBox("3. 사진을 제외한 모든 개체/도형을 정리하시겠습니까?" & vbCrLf & _
                      "(시트별 삭제 결과 요약 창이 표시됩니다)", vbYesNo + vbQuestion, "개체/도형 정리")
    If response = vbYes Then
        AllShapeDelete
        ' AllShapeDelete 내부에서 결과 요약을 표시하므로 별도 메시지는 생략
    End If

    ' 4. 외부 연결링크 삭제
    response = MsgBox("4. 외부 연결 링크를 삭제하시겠습니까?", vbYesNo + vbQuestion, "외부 링크 삭제")
    If response = vbYes Then
        totalDeleted = 외부링크삭제()
        MsgBox totalDeleted & "개의 외부 링크가 삭제되었습니다.", vbInformation
    End If

    ' 5. 이미지 압축
    response = MsgBox("5. 이미지를 압축하시겠습니까?", vbYesNo + vbQuestion, "이미지 압축")
    If response = vbYes Then
        이미지압축
        ' 이미지압축 내부에서 안내 메시지를 표시함
    End If

정리:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    endTime = Timer
    MsgBox "최적화 작업이 완료되었습니다!" & vbCrLf & _
           "소요 시간: " & Format(endTime - startTime, "0.0") & "초", _
           vbInformation, "완료"
    Exit Sub

ErrorHandler:
    MsgBox "오류가 발생했습니다: " & Err.Description, vbCritical
    Resume 정리
End Sub

'-------------------------------
' 스타일 삭제
'-------------------------------
Private Sub 스타일삭제()
    Dim st As Style
    Dim stylesToDelete As Collection
    Dim i As Long

    Set stylesToDelete = New Collection

    ' 기본 스타일을 제외한 사용자 정의 스타일 수집
    For Each st In ActiveWorkbook.Styles
        If Not IsBuiltInStyle(st.Name) Then
            stylesToDelete.Add st.Name
        End If
    Next st

    ' 수집된 스타일 삭제
    For i = 1 To stylesToDelete.Count
        On Error Resume Next
        ActiveWorkbook.Styles(stylesToDelete(i)).Delete
        On Error GoTo 0
    Next i
End Sub

Private Function IsBuiltInStyle(styleName As String) As Boolean
    Dim builtInStyles As Variant
    Dim i As Long

    builtInStyles = Array( _
        "Normal", "Comma", "Currency", "Percent", "Comma [0]", _
        "Currency [0]", "Hyperlink", "Followed Hyperlink", _
        "Good", "Bad", "Neutral", "Calculation", "Check Cell", _
        "Explanatory Text", "Input", "Linked Cell", "Note", _
        "Output", "Warning Text", "Heading 1", "Heading 2", _
        "Heading 3", "Heading 4", "Title", "Total")

    For i = LBound(builtInStyles) To UBound(builtInStyles)
        If StrComp(styleName, builtInStyles(i), vbTextCompare) = 0 Then
            IsBuiltInStyle = True
            Exit Function
        End If
    Next i
    IsBuiltInStyle = False
End Function

'-------------------------------
' 오류난 이름 정의 삭제
'-------------------------------
Private Function 오류이름삭제() As Long
    Dim nm As Name
    Dim deletedCount As Long
    Dim namesToDelete As Collection
    Dim i As Long

    Set namesToDelete = New Collection
    deletedCount = 0

    For Each nm In ActiveWorkbook.Names
        On Error Resume Next
        If InStr(1, nm.RefersTo, "#REF!", vbTextCompare) > 0 Then
            namesToDelete.Add nm.Name
        ElseIf Not nm Is Nothing Then
            ' 범위가 아닐 수도 있으니 접근 시 예외 처리
            Dim tmp As Variant
            tmp = nm.RefersTo
        End If
        On Error GoTo 0
    Next nm

    For i = 1 To namesToDelete.Count
        On Error Resume Next
        ActiveWorkbook.Names(namesToDelete(i)).Delete
        If Err.Number = 0 Then deletedCount = deletedCount + 1
        On Error GoTo 0
    Next i

    오류이름삭제 = deletedCount
End Function

'-------------------------------
' 사진을 제외한 개체/도형 일괄 삭제 (시트별 보고)
'-------------------------------
Public Sub AllShapeDelete()
    Dim ws As Worksheet
    Dim result As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    result = "개체/도형 삭제 결과:" & vbCrLf & vbCrLf

    For Each ws In ActiveWorkbook.Worksheets
        result = result & "워크시트: " & ws.Name & vbCrLf
        result = result & 워크시트개체삭제(ws) & vbCrLf & vbCrLf
    Next ws

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox result, vbInformation, "개체/도형 정리 완료"
End Sub

Private Function 워크시트개체삭제(ws As Worksheet) As String
    Dim deleteCount As Long

    deleteCount = 0
    deleteCount = deleteCount + Shapes컬렉션삭제(ws)     ' 사진 제외
    deleteCount = deleteCount + DrawingObjects삭제(ws)   ' 구버전 포함, 사진 제외
    deleteCount = deleteCount + OLEObjects삭제(ws)       ' ActiveX 등

    워크시트개체삭제 = "  삭제된 개체 수: " & deleteCount & "개"
End Function

Private Function Shapes컬렉션삭제(ws As Worksheet) As Long
    Dim i As Long
    Dim shp As Shape
    Dim deleteCount As Long

    On Error Resume Next
    For i = ws.Shapes.Count To 1 Step -1
        Set shp = ws.Shapes(i)
        If Not shp Is Nothing Then
            ' 사진 및 연결된 사진은 보존
            If shp.Type <> msoPicture And shp.Type <> msoLinkedPicture Then
                shp.Delete
                If Err.Number = 0 Then deleteCount = deleteCount + 1 Else Err.Clear
            End If
        End If
    Next i
    On Error GoTo 0

    Shapes컬렉션삭제 = deleteCount
End Function

Private Function DrawingObjects삭제(ws As Worksheet) As Long
    Dim i As Long
    Dim obj As Object
    Dim deleteCount As Long

    On Error Resume Next
    For i = ws.DrawingObjects.Count To 1 Step -1
        Set obj = ws.DrawingObjects(i)
        If Not obj Is Nothing Then
            ' TypeName으로 사진 제외
            If TypeName(obj) <> "Picture" Then
                obj.Delete
                If Err.Number = 0 Then deleteCount = deleteCount + 1 Else Err.Clear
            End If
        End If
    Next i
    On Error GoTo 0

    DrawingObjects삭제 = deleteCount
End Function

Private Function OLEObjects삭제(ws As Worksheet) As Long
    Dim i As Long
    Dim oleObj As OLEObject
    Dim deleteCount As Long

    On Error Resume Next
    For i = ws.OLEObjects.Count To 1 Step -1
        Set oleObj = ws.OLEObjects(i)
        If Not oleObj Is Nothing Then
            oleObj.Delete
            If Err.Number = 0 Then deleteCount = deleteCount + 1 Else Err.Clear
        End If
    Next i
    On Error GoTo 0

    OLEObjects삭제 = deleteCount
End Function

'Private Function ChartObjects삭제(ws As Worksheet) As Long
'    Dim i As Long
'    Dim deleteCount As Long
'
'    On Error Resume Next
'    For i = ws.ChartObjects.Count To 1 Step -1
'        ws.ChartObjects(i).Delete
'        If Err.Number = 0 Then deleteCount = deleteCount + 1 Else Err.Clear
'    Next i
'    On Error GoTo 0
'
'    ChartObjects삭제 = deleteCount
'End Function
'
'Private Function Comments삭제(ws As Worksheet) As Long
'    Dim deleteCount As Long
'
'    On Error Resume Next
'    ' 현대 버전: CommentsThreaded
'    If ws.CommentsThreaded.Count > 0 Then
'        ws.CommentsThreaded.Delete
'        If Err.Number = 0 Then deleteCount = deleteCount + 1 Else Err.Clear
'    End If
'    ' 구버전: Comments
'    If ws.Comments.Count > 0 Then
'        ws.Comments.Delete
'        If Err.Number = 0 Then deleteCount = deleteCount + 1 Else Err.Clear
'    End If
'    On Error GoTo 0
'
'    Comments삭제 = deleteCount
'End Function

'-------------------------------
' 외부 링크 끊기
'-------------------------------
Private Function 외부링크삭제() As Long
    Dim linksVar As Variant
    Dim i As Long
    Dim deletedCount As Long

    deletedCount = 0
    linksVar = ActiveWorkbook.LinkSources(xlExcelLinks)

    If Not IsEmpty(linksVar) Then
        For i = LBound(linksVar) To UBound(linksVar)
            On Error Resume Next
            ActiveWorkbook.BreakLink Name:=linksVar(i), Type:=xlLinkTypeExcelLinks
            If Err.Number = 0 Then deletedCount = deletedCount + 1 Else Err.Clear
            On Error GoTo 0
        Next i
    End If

    외부링크삭제 = deletedCount
End Function

'-------------------------------
' 이미지 압축 (간이/호환 방식)
'-------------------------------

Sub 이미지압축()
Dim i As Integer
Dim sht As Integer

Application.ScreenUpdating = False
On Error Resume Next
sht = InputBox("모든 시트의 사진을 압축할까요? " & vbCrLf & "모든시트 : 1,  현재시트만 : 2", Default:=1)

If IsNumeric(sht) And sht = 2 Then
    ActiveSheet.Shapes.SelectAll
        SendKeys "%w", True
        SendKeys "%d", True
        SendKeys "%a", True
        SendKeys "~", True
    Application.CommandBars.ExecuteMso "PicturesCompress"
'    SendKeys "{ESC}", True
ElseIf IsNumeric(sht) And sht = 1 Then
    For i = 1 To Sheets.Count
        Sheets(i).Shapes.SelectAll
            SendKeys "%w", True
            SendKeys "%d", True
            SendKeys "%a", True
            SendKeys "~", True
        Application.CommandBars.ExecuteMso "PicturesCompress"

    Next i
'    SendKeys "{ESC}", True
End If

Application.ScreenUpdating = True
SendKeys "{ESC}", True
SendKeys "{NUMLOCK}", True
Application.Wait (Now + TimeValue("0:00:01"))
End Sub

4. 파일 다운로드

0.18MB

엑셀VBA 병합셀에 사진 한방에 넣기!

노만e — Mon, 18 Aug 2025 20:33:57 +0900

수백 개 이미지도 1분안에 자동 삽입하는 VBA 마법!!

아래의 양식이 아니어도 상관없습니다.

여러분의 양식에 아래 첨부된 VBA 코드를 복사 붙여 넣고 사용하시면 됩니다.

"병합셀마다 일일이 사진 넣느라 하루 종일 걸렸던 당신, 이제 Stop!"

엑셀로 카탈로그, 상품목록, 직원명부를 만들 때 가장 귀찮은 작업이 뭘까요?

그건 바로 병합셀마다 하나씩 이미지를 삽입하는 작업이죠.

수십, 수백 개의 사진을 넣어야 할 때면 정말 막막합니다.

하지만 이제 걱정 끝!

단 한 번의 클릭으로 모든 병합셀에 이미지를 자동으로 삽입해주는 VBA 매크로를 소개합니다.

✨ 이런 분들께 강력 추천!

상품 카탈로그 제작하시는 분
직원 명부에 프로필 사진 넣으시는 분
회사 소개서, 프레젠테이션 자료 만드시는 분
재고 관리표에 제품 이미지 넣으시는 분
포트폴리오, 갤러리 형태 문서 작성하시는 분

핵심 기능 한눈에 보기

1️⃣ 똑똑한 자동 인식

✅ 빈 병합셀만 자동으로 찾아서 처리
✅ 이미지가 이미 있는 곳은 건드리지 않음
✅ 원하는 크기 이상의 병합셀만 선택 가능
✅ VBA코드만 복사해서 임의의 양식에 적용 가능

2️⃣ 두 가지 입력 모드

자동 모드: 폴더 선택하면 이름순으로 자동 배치
수동 모드: 각 셀마다 원하는 이미지 직접 선택

3️⃣ 완벽한 크기 조절

딱맞게: 병합셀 전체 영역 활용
조금 작게: 여백을 둬서 깔끔하게
더 작게: 넉넉한 여백으로 세련되게

사용법 완벽 가이드

STEP 1: VBA 코드 적용하기

1. Alt + F11로 VBA 에디터 열기
2. 삽입 → 모듈 선택
3. 제공된 코드 전체 복사&붙여넣기
4. Ctrl + S로 저장

STEP 2: 마법사 실행하기

1. Alt + F8 (또는 개발도구 → 매크로)
2. "PictureFill_MergedCells_Wizard" 선택 후 실행
3. 단계별 안내에 따라 설정

STEP 3: 설정 완료하기

병합행 개수: 몇 행 이상 병합셀에 넣을지 결정 (예: 3행)
크기 옵션: 1(딱맞게) / 2(조금 작게) / 3(더 작게)
입력 방식: 1(자동) / 2(수동)

※ VBA 코드

Option Explicit

' ============================================
' 병합셀 사진 삽입 위저드 (자동/수동 선택)
' - 병합행 수 기준(cnt) 이상 + "값이 비어 있고" + "그림 없는" 병합셀만 대상
' - 모드 1: 폴더 내 이미지 자동 배치(이름순)
' - 모드 2: 각 병합셀마다 파일 직접 선택
' - 크기 옵션: 1=딱맞게, 2=조금 작게, 3=더 작게
' - 파일명(확장자 제외) 기록 위치: 병합셀의 "다음 행 첫 칸"
'   예) A3:F14 병합 → A15에 파일명
' ============================================

Public Sub PictureFill_MergedCells_Wizard()
    Dim rTable As Range, rng As Range
    Dim cnt As Long, picSize As Long, modeSel As Long
    Dim prng() As Range
    Dim i As Long, j As Long

    Dim folderPath As String
    Dim imgFiles() As String
    Dim imgCount As Long
    Dim maxN As Long

    Application.ScreenUpdating = False
    On Error GoTo SafeExit

    ' 1) 대상 범위: 현재 시트 사용영역
    Set rTable = ActiveSheet.UsedRange
    If rTable Is Nothing Then GoTo SafeExit

    ' 2) 병합행 최소 개수
    cnt = Application.InputBox("병합셀이 몇 행 이상일 때 사진을 입력할까요?", _
                               "병합셀 행 개수 기준", Default:=3, Type:=1)
    If cnt <= 0 Then GoTo SafeExit

    ' 3) 크기 옵션
    picSize = Application.InputBox("사진의 크기를 선택하세요:" & vbCrLf & _
                                   "1: 딱맞게, 2: 조금 작게, 3: 더 작게", _
                                   "크기 옵션", Default:=1, Type:=1)
    If picSize < 1 Or picSize > 3 Then GoTo SafeExit

    ' 4) 입력 방식 선택
    modeSel = Application.InputBox("입력 방식을 선택하세요:" & vbCrLf & _
                                   "1: 폴더 자동 입력(이름순)" & vbCrLf & _
                                   "2: 개별 파일 수동 선택", _
                                   "입력 방식", Default:=1, Type:=1)
    If (modeSel <> 1) And (modeSel <> 2) Then GoTo SafeExit

    ' 5) 조건을 만족하는 병합셀 수집
    i = 0
    For Each rng In rTable
        If rng.MergeCells Then
            If rng.Address = rng.MergeArea.Cells(1, 1).Address Then
                If rng.MergeArea.Rows.Count >= cnt Then
                    ' *** 수정 포인트 ***
                    '   값이 완전히 비어 있고(CountA=0)
                    '   + 그림(사진)이 겹치지 않는 병합셀만 수집
                    If IsRangeEmpty(rng.MergeArea) Then
                        If Not RangeHasImage(rng.MergeArea) Then
                            i = i + 1
                            ReDim Preserve prng(1 To i)
                            Set prng(i) = rng.MergeArea
                        End If
                    End If
                End If
            End If
        End If
    Next rng

    If i = 0 Then
        MsgBox "조건(비어있고 그림이 없는) 병합셀이 없습니다.", vbInformation
        GoTo SafeExit
    End If

    ' 6) 모드 분기
    If modeSel = 1 Then
        ' ---- 자동 모드: 폴더 선택 → 이미지 목록 수집 → 이름순 정렬 후 순서대로
        folderPath = PickFolderPath("이미지 폴더를 선택하세요")
        If Len(folderPath) = 0 Then GoTo SafeExit

        imgCount = GetImageFiles(folderPath, imgFiles)
        If imgCount = 0 Then
            MsgBox "선택한 폴더에 사용할 수 있는 이미지 파일이 없습니다.", vbInformation
            GoTo SafeExit
        End If

        If imgCount > 1 Then QuickSortStrings imgFiles, LBound(imgFiles), UBound(imgFiles)

        maxN = IIf(imgCount < UBound(prng), imgCount, UBound(prng))

        For j = 1 To maxN
            ' 이중 안전장치: 삽입 직전에도 한 번 더 검사
            If IsRangeEmpty(prng(j)) And Not RangeHasImage(prng(j)) Then
                InsertImageIntoMerged prng(j), imgFiles(j), picSize
                'WriteFilenameBelow prng(j), BaseNameWithoutExt(imgFiles(j))
            End If
        Next j

        If imgCount < UBound(prng) Then
            MsgBox "이미지가 " & imgCount & "개여서 " & imgCount & "개의 병합셀만 채웠습니다.", vbInformation
        End If

    ElseIf modeSel = 2 Then
        ' ---- 수동 모드: 각 병합셀마다 파일 직접 선택
        Dim strFilter As String, fullPath As Variant
        strFilter = "그림파일 (*.jpg;*.jpeg;*.png;*.gif;*.bmp;*.tif;*.tiff),*.jpg;*.jpeg;*.png;*.gif;*.bmp;*.tif;*.tiff"

        For j = 1 To UBound(prng)
            fullPath = Application.GetOpenFilename( _
                        FileFilter:=strFilter, _
                        Title:="삽입할 그림 파일을 선택하세요", _
                        MultiSelect:=False)
            If VarType(fullPath) = vbBoolean Then Exit For ' 취소하면 종료
            If CStr(fullPath) <> "False" Then
                If IsRangeEmpty(prng(j)) And Not RangeHasImage(prng(j)) Then
                    InsertImageIntoMerged prng(j), CStr(fullPath), picSize
                    'WriteFilenameBelow prng(j), BaseNameWithoutExt(CStr(fullPath))
                End If
            Else
                Exit For
            End If
        Next j
    End If

SafeExit:
    Application.ScreenUpdating = True
End Sub

' ============================================
' 헬퍼: 병합셀에 그림 삽입 (크기 옵션 적용)
' ============================================
Private Sub InsertImageIntoMerged(ByVal tgt As Range, ByVal filePath As String, ByVal picSize As Long)
    Dim shp As Shape
    Dim margin As Double

    ' 크기 옵션에 따른 여백 (필요시 가감)
    margin = 2 * picSize

    Set shp = ActiveSheet.Shapes.AddPicture( _
                Filename:=filePath, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=tgt.Left + margin, _
                Top:=tgt.Top + margin, _
                Width:=Application.Max(4, tgt.Width - (margin * 2)), _
                Height:=Application.Max(4, tgt.Height - (margin * 2)))
    With shp
        .LockAspectRatio = msoFalse
        .Left = tgt.Left + margin
        .Top = tgt.Top + margin
        .Width = Application.Max(4, tgt.Width - (margin * 2))
        .Height = Application.Max(4, tgt.Height - (margin * 2))
    End With
End Sub

' ============================================
' *** 추가 헬퍼: 범위가 "값이 비었는지" 체크 (CountA=0)
'   - 공백/서식만 있는 경우도 비었다고 간주
' ============================================
Private Function IsRangeEmpty(ByVal R As Range) As Boolean
    On Error Resume Next
    IsRangeEmpty = (Application.WorksheetFunction.CountA(R) = 0)
    On Error GoTo 0
End Function

' ============================================
' *** 추가 헬퍼: 범위 내에 "그림(Shape)"이 있는지 검사
'   - msoPicture / msoLinkedPicture 타입을 바운딩 박스 겹침으로 판정
'   - TopLeft/BottomRightCell이 애매한 경우도 대비해 좌표 겹침 검사
' ============================================
Private Function RangeHasImage(ByVal tgt As Range) As Boolean
    Dim shp As Shape
    Dim L As Double, T As Double, R As Double, B As Double

    L = tgt.Left: T = tgt.Top: R = tgt.Left + tgt.Width: B = tgt.Top + tgt.Height

    For Each shp In ActiveSheet.Shapes
        ' 그림 계열만 체크(그룹 등은 제외)
        If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then
            ' 사각형 바운딩 박스 겹침 여부
            If (shp.Left < R) And ((shp.Left + shp.Width) > L) And _
               (shp.Top < B) And ((shp.Top + shp.Height) > T) Then
                RangeHasImage = True
                Exit Function
            End If
        End If
    Next shp
    RangeHasImage = False
End Function

' ============================================
' 헬퍼: 병합셀의 다음 행 첫 칸에 파일명(확장자 제외) 쓰기
'   예) A3:F14 → A15
' ============================================
'Private Sub WriteFilenameBelow(ByVal tgt As Range, ByVal baseName As String)
'    Dim belowCell As Range
'    Set belowCell = tgt.Cells(tgt.Rows.Count, 1).Offset(1, 0)
'    belowCell.Value = baseName
'End Sub

' ============================================
' 헬퍼: 폴더 선택
' ============================================
Private Function PickFolderPath(ByVal prompt As String) As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = prompt
        .AllowMultiSelect = False
        If .Show = -1 Then
            PickFolderPath = .SelectedItems(1)
        Else
            PickFolderPath = vbNullString
        End If
    End With
End Function

' ============================================
' 헬퍼: 폴더 내 이미지 파일 목록 수집
' 지원 확장자: jpg, jpeg, png, gif, bmp, tif, tiff
' ============================================
Private Function GetImageFiles(ByVal folderPath As String, ByRef arr() As String) As Long
    Dim f As String, n As Long, ext As String

    If Right$(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    f = Dir(folderPath & "*.*")
    Do While Len(f) > 0
        If InStrRev(f, ".") > 0 Then
            ext = LCase$(Mid$(f, InStrRev(f, ".") + 1))
            If ext Like "jpg" Or ext Like "jpeg" Or ext Like "png" Or _
               ext Like "gif" Or ext Like "bmp" Or ext Like "tif" Or ext Like "tiff" Then
                n = n + 1
                ReDim Preserve arr(1 To n)
                arr(n) = folderPath & f
            End If
        End If
        f = Dir()
    Loop

    GetImageFiles = n
End Function

' ============================================
' 헬퍼: 파일경로 → 파일명(확장자 제외)
' ============================================
Private Function BaseNameWithoutExt(ByVal filePath As String) As String
    Dim nameWithExt As String, p As Long
    nameWithExt = Mid$(filePath, InStrRev(filePath, "\") + 1)
    p = InStrRev(nameWithExt, ".")
    If p > 0 Then
        BaseNameWithoutExt = Left$(nameWithExt, p - 1)
    Else
        BaseNameWithoutExt = nameWithExt
    End If
End Function

' ============================================
' 헬퍼: 문자열 배열 퀵정렬 (오름차순)
' ============================================
Private Sub QuickSortStrings(ByRef A() As String, ByVal first As Long, ByVal last As Long)
    Dim i As Long, j As Long
    Dim pivot As String, tmp As String
    i = first: j = last
    pivot = A((first + last) \ 2)
    Do While i <= j
        Do While A(i) < pivot: i = i + 1: Loop
        Do While A(j) > pivot: j = j - 1: Loop
        If i <= j Then
            tmp = A(i): A(i) = A(j): A(j) = tmp
            i = i + 1: j = j - 1
        End If
    Loop
    If first < j Then QuickSortStrings A, first, j
    If i < last Then QuickSortStrings A, i, last
End Sub

' ============================================
' (선택) 바로 실행 가능한 단축 루틴
' ============================================
Public Sub Picture_Auto_From_Folder()
    PictureFill_MergedCells_Wizard
End Sub

Public Sub Picture_Manual_File_By_File()
    PictureFill_MergedCells_Wizard
End Sub

실제 활용 사례

상품 카탈로그 제작

상품명이 적힌 병합셀에 제품 이미지 자동 삽입
폴더에 제품사진들을 넣어두고 한 번에 처리

직원 명부 업데이트

직원 정보가 들어간 병합셀에 프로필 사진 추가
신입사원 사진도 빠르게 일괄 적용

부동산 매물 리스트

매물 정보와 함께 현장 사진들을 효율적으로 배치
수십 개 매물도 몇 분 만에 완성

Pro Tips & 주의사항

✅ 이렇게 하면 더 좋아요!

이미지 파일명을 순서대로 정리해두세요 (001_상품A.jpg, 002_상품B.jpg)
폴더 하나에 해당 프로젝트 이미지만 넣어두세요
병합셀 크기를 미리 적절히 조정해두세요

⚠️ 이것만은 주의하세요!

매크로 보안 설정이 차단되어 있다면 해제 필요
이미지 파일이 너무 크면 엑셀이 느려질 수 있음
작업 전 백업본을 꼭 만들어두세요

다른 업무에도 응용 가능!

이 VBA는 단순히 상품 카탈로그만을 위한 것이 아닙니다!

회계/재무 보고서의 차트 이미지 자동 삽입
마케팅 자료의 캠페인 이미지 일괄 처리
교육 자료의 설명 이미지 자동 배치
의료 차트의 환자 사진/X-ray 이미지 관리
️ 건설/제조업의 현장 사진 정리

당신만의 업무 스타일에 맞게 얼마든지 커스터마이징 가능합니다!

마무리하며...

하루 종일 걸리던 이미지 삽입 작업이 이제 단 몇 분으로 단축됩니다.

더 이상 반복 작업에 시간을 낭비하지 마세요. 생산성 향상의 첫걸음은 바로 자동화입니다!

병합셀_폴더내 사진 자동삽입_ver1.1.xlsm

연차 촉진 사용 계획서 PDF 대량 출력 자동화 – 클릭 한 번으로 수천 명 완성!_메일머지

노만e — Fri, 15 Aug 2025 18:45:56 +0900

회사에서 직원별 연차계획서를 작성하고, 이를 PDF 파일로 개별 저장해야 하는 상황이라면 … ㅠ.ㅠ;;
직원이 5명만 돼도 귀찮은데, 3,000명이 넘으면 하루 종일 걸릴 수도 있죠.

오늘은 엑셀 VBA를 이용해, 클릭 한 번으로 연차계획서 PDF를 대량으로 자동 저장하는 방법을 소개합니다.
이 매크로는 사원 정보 시트를 읽고, 각 직원의 정보로 인쇄 양식을 채운 뒤, PDF 파일로 각각 저장해 줍니다.

✨ 기능 개요

사원정보 시트에 저장된 직원 데이터를 한 줄씩 읽어서
연차사용촉진서식 시트의 지정된 셀에 자동 입력
파일명에 쓸 수 없는 문자를 제거
선택한 폴더에 직원별 PDF로 저장

VBA 코드 설명

1. 파일명에 쓸 수 없는 문자 제거 함수

Private Function CleanFileName(ByVal s As String) As String
    Dim badChars As Variant, i As Long
    badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    CleanFileName = s
    For i = LBound(badChars) To UBound(badChars)
        CleanFileName = Replace(CleanFileName, badChars(i), " ")
    Next i
    CleanFileName = Trim(CleanFileName)
    If Len(CleanFileName) = 0 Then CleanFileName = "Unnamed"
End Function

왜 필요할까요?
Windows 파일명에는 \, /, :, *, ?, ", <, >, | 같은 문자를 쓸 수 없습니다.
이 함수는 그런 문자들을 자동으로 제거해서 저장 오류를 방지합니다.

2. PDF 대량 저장 메인 코드

Public Sub 연차계획서_PDF_대량출력()
    Dim wsData As Worksheet, wsForm As Worksheet
    Dim lastRow As Long, r As Long
    Dim dept As String, emp As String, title As String
    Dim occDate As Variant, period As String
    Dim aDays As Variant, bDays As Variant, remainDays As Variant
    Dim savePath As String, fName As String
    Dim fd As FileDialog

wsData : 사원 목록 시트 (사원정보)
wsForm : 인쇄용 서식 시트 (연차사용촉진서식)
반복문(For r = 2 To lastRow)으로 각 직원 정보 읽기

3. 저장 폴더 선택

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
    .title = "PDF를 저장할 폴더를 선택하세요"
    If .Show <> -1 Then Exit Sub
    savePath = .SelectedItems(1)
End With

매크로 실행 시, 사용자가 저장할 폴더를 직접 선택할 수 있습니다.

4. 서식 채우기

With wsForm
    .Range("D4").Value = dept
    .Range("M4").Value = emp
    .Range("U4").Value = title
    .Range("B8").Value = occDate
    .Range("I8").Value = period
    .Range("P8").Value = aDays
    .Range("S8").Value = bDays
    .Range("V8").Value = remainDays
    .Range("B11").Value = "2025년  6월  30일까지"
    .Range("B31").Value = "2025년  6월  15일"
    .Range("B34").Value = "통보서 수령확인 :                " & emp & "   (인)"
End With

각 셀에 해당 직원의 정보를 채움
날짜나 문구는 고정값으로도 지정 가능

5. PDF 저장

fName = savePath & "\" & CleanFileName(CStr(emp)) & ".pdf"
wsForm.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=fName, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

직원 이름을 파일명으로 사용 (CleanFileName 함수로 안전 처리)
ExportAsFixedFormat 메서드로 PDF 저장

자주 하는 실수 & 팁

시트 이름 불일치
- "사원정보", "연차사용촉진서식" 시트 이름은 본인 파일에 맞게 변경하세요.
셀 주소 다름
- D4, M4 등 입력되는 셀 주소가 서식 파일 구조와 다르면 데이터가 엉뚱한 곳에 들어갑니다.
날짜 서식
- 날짜는 엑셀에서 날짜 형식으로 저장되어 있어야 합니다. 텍스트로 되어 있으면 서식이 깨질 수 있습니다

마무리

이 매크로를 활용하면, 매달 수십 명의 연차계획서를 5분 안에 PDF로 완성할 수 있습니다.
반복 작업을 줄여 시간을 절약하고, 오류 가능성도 줄여주죠.

연차 촉진 사용 계획서.xlsm

시트 범위를 이미지(PNG/JPG 등) 파일로 저장하기

노만e — Tue, 12 Aug 2025 17:20:49 +0900

안녕하세요! 오늘은 엑셀에서 특정 범위를 선택해서 바로 그림 파일로 저장하는 VBA 매크로를 만들어 보겠습니다.
보고서 작성, 이미지 자료 공유, 보고용 캡처 등에 아주 유용하게 쓸 수 있는 방법이에요.

1. 기능 소개

이번에 만들 매크로는 이렇게 동작합니다.

마우스로 저장하고 싶은 범위를 선택합니다.
저장할 파일 이름과 형식을 지정합니다.
선택한 범위를 이미지 파일(PNG/JPG/GIF/BMP/TIF)로 저장합니다.

장점

해상도 손상 없이 원본 크기로 저장
범위 지정만 하면 시트 전체가 아니라 필요한 부분만 저장 가능
다양한 이미지 포맷 지원

2. VBA 코드

아래 코드를 **표준 모듈(Module)**에 붙여 넣으시면 됩니다.

Option Explicit

Public Sub SaveSelectedRangeAsImage()
    Dim rng As Range
    Dim ws As Worksheet
    Dim savePath As Variant
    Dim ext As String, filterName As String
    Dim co As ChartObject
    Dim oldScrUp As Boolean

    ' 범위 선택
    On Error Resume Next
    Set rng = Application.InputBox(Prompt:="이미지로 저장할 범위를 마우스로 선택하세요.", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub

    Set ws = rng.Worksheet

    ' 저장 파일명/형식 선택
    savePath = Application.GetSaveAsFilename( _
        InitialFileName:=ThisWorkbook.Path & "\" & ws.Name & "_" & Format(Now, "yyyymmdd_hhnnss") & ".png", _
        FileFilter:="PNG 파일 (*.png), *.png, JPG 파일 (*.jpg;*.jpeg), *.jpg;*.jpeg, GIF 파일 (*.gif), *.gif, BMP 파일 (*.bmp), *.bmp, TIF 파일 (*.tif;*.tiff), *.tif;*.tiff")
    If savePath = False Then Exit Sub

    ext = LCase$(Mid$(CStr(savePath), InStrRev(CStr(savePath), ".") + 1))
    Select Case ext
        Case "png": filterName = "PNG"
        Case "jpg", "jpeg": filterName = "JPG"
        Case "gif": filterName = "GIF"
        Case "bmp": filterName = "BMP"
        Case "tif", "tiff": filterName = "TIF"
        Case Else
            MsgBox "지원하지 않는 확장자입니다. PNG/JPG/GIF/BMP/TIF 중에서 선택하세요.", vbExclamation
            Exit Sub
    End Select

    oldScrUp = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Application.CutCopyMode = False

    ' 범위를 그림으로 복사
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    ' 임시 차트에 붙여넣고 저장
    Set co = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    With co
        .Activate
        .Chart.Paste
        .Chart.Export Filename:=CStr(savePath), FilterName:=filterName
        .Delete
    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = oldScrUp

    MsgBox "저장 완료! " & CStr(savePath), vbInformation
End Sub

3. 코드 해설

3-1. 범위 선택

Set rng = Application.InputBox(Prompt:="이미지로 저장할 범위를 마우스로 선택하세요.", Type:=8)

Type:=8 → 범위를 직접 마우스로 선택할 수 있도록 지정
선택을 취소하면 매크로가 종료됩니다.

3-2. 파일 저장 형식 선택

savePath = Application.GetSaveAsFilename( ... )

PNG, JPG, GIF, BMP, TIF 총 5가지 형식을 지원
초기 파일명은 "시트이름_날짜시간.png" 형식으로 자동 지정

3-3. 범위를 이미지로 변환

rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Excel의 범위를 클립보드에 그림 형태로 복사
Format:=xlBitmap 으로 변경하면 비트맵 방식으로 복사 가능 (일부 환경에서 선명도 차이 발생)

3-4. 임시 차트 객체에 붙여넣기 후 저장

Set co = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
.Chart.Paste
.Chart.Export Filename:=CStr(savePath), FilterName:=filterName

차트 객체(ChartObject)는 이미지로 내보내기 기능을 지원하기 때문에, 여기에 붙여서 저장
저장 후 임시 차트는 .Delete 로 제거

4. 실행 방법

Alt + F11 → VBA 편집기 실행
삽입 → 모듈 클릭
위 코드 붙여넣기
엑셀로 돌아가서 Alt + F8 → SaveSelectedRangeAsImage 실행
범위 선택 → 저장 형식 선택 → 이미지파일 생성 완료!

5. 활용 팁

보고서 캡처 자동화
매일/매주 반복되는 보고 자료를 일정 범위만 자동 저장하면 시간 절약!
고해상도 저장
저장 전에 **줌(Zoom) 120~160%**로 확대 후 저장하면 더 선명하게 나옵니다.
자동 범위 지정
Set rng = ws.Range("A1:H30")처럼 범위를 고정하면 클릭 없이 바로 저장됩니다.

6. 마무리

이 매크로는 범위 → 이미지 변환 → 파일 저장 과정을 완전히 자동화해 줍니다.
특히 보고서 작성이나 블로그·프레젠테이션에 넣을 때 특히 유용하게 쓸 수 있으니,

한번 만들어 두시면 두고두고 편하게 사용하실 수 있습니다.

범위를 그림 파일로 저장.xlsm

0.17MB

엑셀 마우스 클릭만으로 수천장 사진 대지 완성! VBA 자동화 풀세팅

노만e — Mon, 11 Aug 2025 23:44:56 +0900

엑셀에서 ‘사진 자동 배치’ 완전 자동화! (1장·2장·4장·6장 레이아웃 지원)

이 글은 이런 분께 추천드려요!

여러 장의 사진을 한 번에 깔끔하게 배치하고 싶은 분
병합 셀에 맞춰서 사진이 자동으로 사이즈 조절되길 원하는 분
1장, 2장, 4장, 6장 템플릿별로 쉽게 변경하고 싶은 분
사진 크기를 한 번에 크게/작게 조정하고 싶은 분

1. 기능 개요

이 매크로는 엑셀 시트 템플릿에 맞춰서 사진을 자동 배치해 주는 프로그램입니다.

기능 하이라이트
✅ 메인 화면에서 버튼 클릭 → 레이아웃 선택
✅ 사진 개수만 입력 → 자동 페이지 생성
✅ 폴더 선택 → 이미지 자동 삽입
✅ 병합 셀 크기에 딱 맞춰서 사이즈 조절
✅ 사진 크기 옵션(딱 맞게 / 조금 작게 / 더 작게) 선택 가능

2. 구성 및 시트 설명

Main 시트 : 시작 화면, 원하는 레이아웃(1장/2장/4장/6장)을 선택
p_1, p_2, p_4, p_6 시트 : 각 레이아웃별 템플릿
- p_1 : 한 페이지에 사진 1장
- p_2 : 한 페이지에 사진 2장
- p_4 : 한 페이지에 사진 4장
- p_6 : 한 페이지에 사진 6장

3. 사용 방법

① 매크로 실행

파일을 열면 Main 시트가 자동으로 열립니다.
원하는 레이아웃 버튼(예: 사진 4장)을 클릭합니다.

② 사진 개수 입력

“사진 ‘수량’을 입력하세요” 팝업창이 뜹니다.
예) 50 입력 시, 필요한 페이지만큼 템플릿이 자동 복제됩니다.

③ 사진 크기 옵션 선택

“사진 크기 옵션” 창이 뜹니다.
- 1 : 병합셀에 딱 맞게
- 2 : 약간 작게
- 3 : 더 작게

④ 사진 폴더 선택

사진이 들어있는 폴더를 선택합니다.
지원 형식: JPG, JPEG, PNG, BMP, GIF, WEBP

⑤ 자동 배치 완료

선택한 병합셀에 사진이 순서대로 들어갑니다.
개수 초과 시, 사진·셀·파일 수 중 최소값만큼만 삽입됩니다.

4. 추가 기능

기존 사진 삭제 : 새로 배치 전, 기존 사진을 모두 제거합니다.
병합셀 자동 인식 : 셀 이름(PIC1..PIC6) 또는 [PIC] 표기 시, 자동 인식합니다.
페이지 경계선 표시 : 각 페이지 경계에 회색 선 표시 가능.
사진 여백 조절 : 큰 사진부터 시작해 여백을 줄이며 최적 배치.

5. 설치 & 실행 방법

엑셀 파일 열기
Alt + F11 → VBA 편집기에서 모듈에 코드 붙여넣기
저장 후 매크로 보안 설정 확인
Main 시트에서 버튼 클릭 후 실행

사진대지_원클릭.xlsm

0.58MB

엑셀 VBA 파일명/폴더명 가져와 일괄 변경

노만e — Sun, 10 Aug 2025 15:38:09 +0900

엑셀로 파일명·폴더명 일괄 변경? 백업·되돌리기까지 한 번에 끝내는 VBA 꿀팁!

업무를 하다보면 여러 개의 파일명을 하나하나 변경할 때가 있습니다. 정말 귀찮죠?
특히 업무 폴더에 수십, 수백 개의 문서가 있으면, 손이 아니라 인내심이 먼저 나가버립니다

그래서 오늘은 엑셀 VBA로 빠르고 정확하게 변경하는 법을 소개 합니다.

폴더 안의 모든 파일/폴더 목록을 불러오고
새 이름으로 일괄 변경하고
잘못 바꿨을 땐 백업/되돌리기까지 가능한

"파일명·폴더명 일괄 변경 자동화 툴" 사용 방법을 알려드립니다.

이 VBA로 할 수 있는 일

이 매크로 파일 하나면 아래 기능을 버튼 클릭으로 실행할 수 있습니다.

폴더 내 일부 파일만 불러오기
폴더 내 모든 파일 불러오기
폴더 내 모든 폴더 목록 불러오기
하위 폴더 포함 모든 파일 불러오기
파일/폴더명 일괄 변경
백업 & 되돌리기

VBA 실행화면 구성

"사진을 클릭해 주세요" 문구가 있는 사진을 클릭시,

매크로 실행 되며, "파일변환" 시트가 자동 생성되고
우측 상단에 기능 버튼들이 깔끔하게 배치됩니다.

버튼 목록

폴더내 일부파일
파일/폴더명 변경
폴더내 모든파일
폴더내 모든폴더
하위폴더 모든파일
백업/되돌리기

⚙ 사용 방법

1. 폴더 내 파일/폴더 목록 불러오기

"폴더내 일부파일" 버튼 → 원하는 파일만 선택 가능
"폴더내 모든파일" 버튼 → 해당 폴더의 모든 파일명과 확장자 자동 입력
"폴더내 모든폴더" 버튼 → 폴더명만 목록화
"하위폴더 모든파일" 버튼 → 하위폴더 포함 전부 불러오기

2. 파일명/폴더명 변경

변경후 열(C, D)에 바꾸고 싶은 이름과 확장자를 입력
"파일/폴더명 변경" 버튼 클릭 → 즉시 변경 완료!

3. 백업 & 되돌리기

변경 전 "백업/되돌리기" 버튼 클릭 → 현재 목록 백업
실수했을 땐 "백업/되돌리기" → 아니오 선택 시 교차복원
- 기존 이름과 새 이름이 서로 자리를 바꿔 복원됨
- 원본 상태로 안전하게 되돌릴 수 있음

안전하게 쓰는 팁

처음에는 복사본 폴더에서 테스트 후 사용하세요.
확장자가 바뀌면 파일이 열리지 않을 수 있으니 주의하세요.
되돌리기 전에 백업을 꼭 해두세요.

매크로 파일 다운로드

파일명 일괄변경.xlsm

0.74MB

✅ 마무리

이 VBA 툴 하나면 파일명 변경 스트레스에서 완전히 해방될 수 있습니다.
백업·되돌리기까지 지원하니 안심하고 사용하세요.

폴더 속 파일에서 원하는 시트만 자동 통합

노만e — Sun, 10 Aug 2025 14:56:05 +0900

폴더내 여러 개의 엑셀 파일에서 딱 한 시트만 골라서 가져와야 할 때,

매번 열어서 복사·붙여넣기 하셨나요?
이번 글에서는 시트 이름을 입력하면 폴더 속 모든 파일에서 해당 시트만 찾아 자동으로 통합하는 VBA 코드를 공유합니다.

기능 요약

매크로 실행 시 시트 이름 입력 창 표시
선택한 폴더 내 모든 엑셀 파일(.xlsx/.xlsm/.xlsb/.csv) 순회
각 파일에서 입력한 시트 이름과 일치하는 시트만 병합
헤더는 첫 번째 파일/시트에서만 포함, 이후는 데이터만 추가
없는 시트가 있는 경우 건너뛰고 결과 메시지에 표시

VBA 코드

Option Explicit

Public Sub CombineSpecificSheetFromFiles()
    On Error GoTo EH

    Dim targetSheetName As String
    Dim fldr As FileDialog
    Dim fol As String
    Dim fName As String
    Dim wbSrc As Workbook
    Dim ws As Worksheet
    Dim master As Worksheet
    Dim firstWrite As Boolean
    Dim nextRow As Long
    Dim dataRng As Range, copyRng As Range
    Dim hdrCols As Long
    Dim skippedFiles As String

    '시트 이름 입력 받기
    targetSheetName = InputBox("가져올 시트 이름을 입력하세요.", "시트 선택")
    If Trim(targetSheetName) = "" Then Exit Sub

    '폴더 선택
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "데이터를 가져올 파일이 있는 폴더 선택"
        If .Show <> -1 Then GoTo CleanExit
        fol = .SelectedItems(1)
    End With

    '마스터 시트 준비
    Set master = GetOrCreateSheet("Master")
    master.Cells.Clear
    firstWrite = True

    '환경 최적화
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    '폴더 내 파일 순회
    fName = Dir(fol & "\*.*")
    Do While Len(fName) > 0
        If IsTargetFile(fName) Then
            Set wbSrc = Workbooks.Open(Filename:=fol & "\" & fName, ReadOnly:=True)

            On Error Resume Next
            Set ws = wbSrc.Sheets(targetSheetName)
            On Error GoTo 0

            If Not ws Is Nothing Then
                Set dataRng = GetDataRange(ws)
                If Not dataRng Is Nothing Then
                    If firstWrite Then
                        hdrCols = dataRng.Columns.Count
                        '헤더
                        master.Range("A1").Resize(1, hdrCols).Value = dataRng.Rows(1).Value
                        master.Cells(1, hdrCols + 1).Value = "SourceFile"

                        '데이터
                        If dataRng.Rows.Count > 1 Then
                            Set copyRng = dataRng.Offset(1).Resize(dataRng.Rows.Count - 1)
                            nextRow = 2
                            master.Cells(nextRow, 1).Resize(copyRng.Rows.Count, hdrCols).Value = copyRng.Value
                            master.Cells(nextRow, hdrCols + 1).Resize(copyRng.Rows.Count, 1).Value = wbSrc.Name
                            nextRow = nextRow + copyRng.Rows.Count
                        Else
                            nextRow = 2
                        End If
                        firstWrite = False
                    Else
                        If dataRng.Rows.Count > 1 Then
                            Set copyRng = dataRng.Offset(1).Resize(dataRng.Rows.Count - 1)
                            nextRow = NextEmptyRow(master)
                            master.Cells(nextRow, 1).Resize(copyRng.Rows.Count, hdrCols).Value = copyRng.Value
                            master.Cells(nextRow, hdrCols + 1).Resize(copyRng.Rows.Count, 1).Value = wbSrc.Name
                        End If
                    End If
                End If
            Else
                skippedFiles = skippedFiles & vbCrLf & fName
            End If

            wbSrc.Close SaveChanges:=False
            Set ws = Nothing
        End If
        fName = Dir
    Loop

    '포맷
    With master
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "데이터 병합 완료" & IIf(skippedFiles <> "", vbCrLf & vbCrLf & _
           "다음 파일에는 해당 시트가 없습니다:" & skippedFiles, ""), vbInformation

    Exit Sub

EH:
    MsgBox "오류 " & Err.Number & " : " & Err.Description, vbExclamation, "CombineSpecificSheetFromFiles"

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

'=== 대상 확장자 필터 ===
Private Function IsTargetFile(ByVal fName As String) As Boolean
    Dim ext As String
    ext = LCase$(Mid$(fName, InStrRev(fName, ".") + 1))
    IsTargetFile = (ext = "xlsx" Or ext = "xlsm" Or ext = "xlsb" Or ext = "csv")
End Function

'=== 마스터 시트 생성/가져오기 ===
Private Function GetOrCreateSheet(ByVal sName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = ThisWorkbook.Worksheets(sName)
    On Error GoTo 0
    If GetOrCreateSheet Is Nothing Then
        Set GetOrCreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        GetOrCreateSheet.Name = sName
    End If
End Function

'=== 실제 데이터 범위 추출 ===
Private Function GetDataRange(ws As Worksheet) As Range
    Dim ur As Range
    On Error Resume Next
    Set ur = ws.UsedRange
    On Error GoTo 0
    If ur Is Nothing Then Exit Function
    If Application.WorksheetFunction.CountA(ur) = 0 Then Exit Function
    Set GetDataRange = ur
End Function

'=== 다음 빈 행 ===
Private Function NextEmptyRow(sh As Worksheet) As Long
    Dim r As Long
    r = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
    If r < 1 Then r = 1
    If Application.WorksheetFunction.CountA(sh.Rows(1)) = 0 Then
        NextEmptyRow = 1
    Else
        NextEmptyRow = r + 1
    End If
End Function

✅ 팁 & 주의사항

시트 이름은 대소문자 구분 없음
구조(열 순서, 헤더)가 동일할수록 결과가 깔끔
없는 시트는 자동 건너뛰고 메시지로 알려줍니다
.xlsx/.xlsm/.xlsb/.csv 모두 지원

마무리 & 구독 유도

이 매크로 하나면 매달 반복되는 시트 통합 작업이 커피 한 잔 마실 시간에 끝납니다.
더 많은 엑셀 자동화 꿀팁을 받고 싶다면,
좋아요 + 구독하기 눌러주시고 다음 포스팅을 기다려주세요!
여러분의 구독이 제게는 최고의 동기부여입니다

특정 시트 이름만 통합.zip

엑셀 VBA 구글 뉴스 크롤링_Ver1.0.xlsm

엑셀 VBA 크롤링-구글 뉴스 최신 기사 자동 수집! (RSS 파싱+키워드 필터 완벽 적용)

노만e — Sat, 9 Aug 2025 23:39:56 +0900

안녕하세요?
오늘은 엑셀에서 원하는 키워드의 뉴스 헤드라인을 자동으로 가져오는 방법을 알려드릴게요.
한 번 입력해 두면, 버튼 한 번 클릭으로 최신 뉴스와 날짜까지 자동 업데이트됩니다.
게다가 언론사 리스트와 키워드 필터 기능까지 넣어서,
관심 있는 뉴스만 골라서 깔끔하게 정리할 수 있어요.

왜 RSS 일까요?
구글 페이지 직접 스크래핑은 약관/차단 리스크가 큽니다.
대신 Google News RSS를 사용하면 안전하고 안정적으로 제목·링크·언론사·발행일을 가져올 수 있어요.

1. 완성 화면 미리보기 (상단 사진 참조)

A열 : 뉴스 제목 (클릭하면 기사로 이동)
B열 : 언론사명
C열 : 날짜
D열 : 정렬용 날짜 (숨김 처리)
G2/H2 : 생성 시각 / 총 기사 수 표시

2. 실행 방법

RSS URL, 언론사, 키워드를 입력
Alt + F8 → Fetch_Headlines_ToSheet 선택 또는 [헤드라인 기사] 버튼 클릭 → 실행
잠시 기다리면 A7부터 최신 뉴스 목록이 깔끔하게 채워집니다.
언론사에 특정 언론사를 구분기호(/)로 입력하면 언론사 필터 가능
키워드에 특정 키워드를 구분기호(/)로 입력하면 키워드 필터 가능

3. 이런 분들께 추천!

관심 있는 분야 뉴스만 모아서 보고 싶은 분
매일 뉴스를 복사/붙여넣기 하느라 힘드셨던 분
엑셀로 데이터 수집 자동화를 배우고 싶은 분

매달 반복하는 엑셀 파일 합치기, 오늘로 끝내드립니다

노만e — Sat, 9 Aug 2025 13:44:56 +0900

안녕하세요, VBA로 업무 시간을 절반 이상 줄여드리는 노만e입니다.

오늘은 회사에서 가장 귀찮은 업무 중 하나인 여러 시트·여러 파일의 데이터 통합을,

단 몇 초 만에 자동으로 처리하는 방법을 알려드리겠습니다.

❗ 돌발 상황

보고서 제출일 전날, 부서별 파일이 수십 개씩 쏟아짐
매번 복사+붙여넣기 하다가 서식 깨짐, 스타일 과다, 스트레스 팍팍
시트별 구조는 같지만 파일이 너무 많아 시간 낭비하고 있다면,

혹시 이런 경험 있으신가요?
이제 이런 고생은 끝입니다.

사용 방법

지점별 과일 매출 통합파일에 있는 [폴더내 데이터 통합] 버튼 클릭
파일이 저장되어 있는 폴더 선택
데이터 통합 완료

✅ 팁

파일 구조가 동일해야 합니다. (열 순서·이름 동일)
*.xlsx *.xlsm 매크로 포함 파일도 합칠 수 있습니다.
시트가 여러 개인 경우도 상관없이 전부 합쳐 집니다.

오늘 공유한 VBA 데이터 합치기 코드, 도움이 되셨나요?
업무 시간을 줄이는 방법을 앞으로도 계속 공유드릴게요.

vba 코드

Option Explicit

Public Sub CombineFilesIntoMaster()
    On Error GoTo EH

    Dim fldr As FileDialog
    Dim fol As String
    Dim wbSrc As Workbook
    Dim ws As Worksheet
    Dim master As Worksheet
    Dim fName As String
    Dim firstWrite As Boolean
    Dim nextRow As Long
    Dim dataRng As Range, copyRng As Range
    Dim hdrCols As Long

    '환경 최적화
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    '폴더 선택
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "데이터를 합칠 폴더를 선택하세요"
        If .Show <> -1 Then GoTo CleanExit '사용자 취소
        fol = .SelectedItems(1)
    End With

    '마스터 시트 준비
    Set master = GetOrCreateSheet("_Master")
    master.Cells.Clear
    firstWrite = True

    '폴더 내 파일 순회
    fName = Dir(fol & "\*.*")
    Do While Len(fName) > 0
        If IsTargetFile(fName) Then
            Set wbSrc = Workbooks.Open(Filename:=fol & "\" & fName, ReadOnly:=True)

            For Each ws In wbSrc.Worksheets
                Set dataRng = GetDataRange(ws)
                If Not dataRng Is Nothing Then
                    If firstWrite Then
                        hdrCols = dataRng.Columns.Count
                        '헤더
                        master.Range("A1").Resize(1, hdrCols).Value = dataRng.Rows(1).Value
                        master.Cells(1, hdrCols + 1).Value = "SourceFile"
                        master.Cells(1, hdrCols + 2).Value = "SourceSheet"

                        '데이터(헤더 제외)
                        If dataRng.Rows.Count > 1 Then
                            Set copyRng = dataRng.Offset(1).Resize(dataRng.Rows.Count - 1)
                            nextRow = 2
                            master.Cells(nextRow, 1).Resize(copyRng.Rows.Count, hdrCols).Value = copyRng.Value
                            master.Cells(nextRow, hdrCols + 1).Resize(copyRng.Rows.Count).Value = wbSrc.Name
                            master.Cells(nextRow, hdrCols + 2).Resize(copyRng.Rows.Count).Value = ws.Name
                            nextRow = nextRow + copyRng.Rows.Count
                        Else
                            nextRow = 2
                        End If
                        firstWrite = False
                    Else
                        '이후 파일/시트: 데이터만
                        If dataRng.Rows.Count > 1 Then
                            Set copyRng = dataRng.Offset(1).Resize(dataRng.Rows.Count - 1)
                            nextRow = NextEmptyRow(master)
                            master.Cells(nextRow, 1).Resize(copyRng.Rows.Count, hdrCols).Value = copyRng.Value
                            master.Cells(nextRow, hdrCols + 1).Resize(copyRng.Rows.Count).Value = wbSrc.Name
                            master.Cells(nextRow, hdrCols + 2).Resize(copyRng.Rows.Count).Value = ws.Name
                        End If
                    End If
                End If
            Next ws

            wbSrc.Close SaveChanges:=False
        End If
        fName = Dir
    Loop

    '포맷
    With master
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With

    MsgBox "데이터 병합 완료 (시트: _Master)", vbInformation, "Combine ?"

CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

EH:
    MsgBox "오류 " & Err.Number & " : " & Err.Description, vbExclamation, "CombineFilesIntoMaster"
    Resume CleanExit
End Sub

'=== 대상 확장자 필터 ===
Private Function IsTargetFile(ByVal fName As String) As Boolean
    Dim ext As String
    ext = LCase$(Mid$(fName, InStrRev(fName, ".") + 1))
    IsTargetFile = (ext = "xlsx" Or ext = "xlsm" Or ext = "xlsb" Or ext = "csv")
End Function

'=== 마스터 시트 생성/가져오기 ===
Private Function GetOrCreateSheet(ByVal sName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = ThisWorkbook.Worksheets(sName)
    On Error GoTo 0
    If GetOrCreateSheet Is Nothing Then
        Set GetOrCreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        GetOrCreateSheet.Name = sName
    End If
End Function

'=== 실제 데이터 범위 추출(빈 시트/머리글만 있는 시트 제외) ===
Private Function GetDataRange(ws As Worksheet) As Range
    Dim ur As Range
    On Error Resume Next
    Set ur = ws.UsedRange
    On Error GoTo 0
    If ur Is Nothing Then Exit Function
    If Application.WorksheetFunction.CountA(ur) = 0 Then Exit Function '빈 시트
    Set GetDataRange = ur
End Function

'=== 다음 빈 행 ===
Private Function NextEmptyRow(sh As Worksheet) As Long
    Dim r As Long
    r = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
    If r < 1 Then r = 1
    If Application.WorksheetFunction.CountA(sh.Rows(1)) = 0 Then
        NextEmptyRow = 1
    Else
        NextEmptyRow = r + 1
    End If
End Function

지점별 과일 매출 통합_예제파일.zip

엑셀VBA로 픽셀아트를 만든다고? 포토샵보다 빠름, 빠름~

노만e — Fri, 8 Aug 2025 10:59:33 +0900

구글 스프레드시트의 확장프로그램중 [픽셀아트]라는 것이 있습니다.

사진을 모자이크로 변환하는 확장프로그램입니다. 엑셀에서도 구현해 보고 싶었습니다.

엑셀에서 이미지를 불러와 자동으로 모자이크(픽셀아트) 효과를 적용하고,

오른쪽에 원본 이미지를 비교 배치하도록 만들었습니다.

이 코드는 GDI API와 WIA 라이브러리를 활용해 이미지를 원하는 크기로 축소·변환한 뒤,

셀 배경색을 픽셀 단위로 채워 픽셀아트를 완성합니다.

주요 기능

이미지 파일 선택 – PNG, JPG, BMP 등 다양한 포맷 지원
해상도 설정 – 가로·세로 픽셀 수와 셀 크기(px) 직접 입력
WIA를 통한 이미지 리사이즈 & BMP 변환 – 고속 처리
셀 배경 채우기 – 각 픽셀 색상을 그대로 반영
오른쪽에 원본 이미지 표시 – 픽셀아트와 비교 가능
임시 파일 자동 삭제 및 환경 복구

사용방법

VBA 편집기(Alt+F11)에서 모듈을 추가하고 코드를 붙여넣습니다.
매크로 실행(Alt+F8) → 변환할 이미지를 선택합니다.
가로·세로 픽셀 수와 셀 크기를 입력하면 자동 변환 완료!

※ 가로, 세로 셀의 숫자가 많고, 셀 한 변의 크기가 작을 수록 더 선명해집니다.

이 코드는 포토샵 없이도 엑셀만으로 모자이크 효과를 구현할 수 있는 코드입니다.
특히 원본 대비 영역까지 자동 배치되므로, 결과 비교가 매우 편리합니다.

vba 코드

Option Explicit

'==========================
'   32/64비트 API 선언
'==========================
#If VBA7 Then
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
#End If

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

'===========================================
'  메인: 이미지 → 픽셀아트 + (오른쪽) 실제 이미지 영역만 원본 배치
'===========================================
Sub PixelArt_FromImage()
    Dim filePath As Variant
    Dim w As Long, h As Long, cellPx As Long
    Dim tmpBmp As String
    Dim topLeft As Range, ws As Worksheet
    Dim ok As Boolean

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error Resume Next

    Set ws = ActiveSheet
    Set topLeft = ActiveCell           ' 좌상단 기준 셀

    ' 1) 이미지 파일 선택
    filePath = Application.GetOpenFilename( _
        "Image Files (*.png;*.jpg;*.jpeg;*.bmp),*.png;*.jpg;*.jpeg;*.bmp", , _
        "픽셀아트로 변환할 이미지를 선택하세요")
    If VarType(filePath) = vbBoolean Then GoTo CleanExit ' 취소 시 종료

    ' 2) 매개변수 입력
    w = CLng(InputBox("가로 픽셀(셀) 수를 입력하세요 (예: 32, 48, 64)", "가로 픽셀", 100))
    If w <= 0 Then GoTo CleanExit
    h = CLng(InputBox("세로 픽셀(셀) 수를 입력하세요 (예: 32, 48, 64)", "세로 픽셀", 100))
    If h <= 0 Then GoTo CleanExit
    cellPx = CLng(InputBox("셀 한 변의 크기(px) 입력 (권장: 12~16)", "셀 크기", 2))
    If cellPx <= 0 Then cellPx = 14

    ' 3) WIA로 축소 & BMP 변환 → 임시 파일 저장
    tmpBmp = Environ$("TEMP") & "\pixel_tmp_" & Format(Now, "yyyymmdd_hhnnss") & ".bmp"
    ok = WIA_ScaleAndSaveAsBMP(CStr(filePath), tmpBmp, w, h)
    If Not ok Then
        MsgBox "이미지 처리에 실패했습니다. (WIA 런타임 필요).", vbExclamation
        GoTo CleanExit
    End If

    ' 4) 좌측: 픽셀아트 그리드/채우기
    PrepareSquareGrid ws, topLeft, w, h, cellPx
    PaintCellsFromBitmap tmpBmp, ws, topLeft, w, h

    ' 5) 우측: 한 칸 띄우고 '실제 이미지 영역(drawW×drawH)'만큼만 원본 삽입
    PlaceOriginalImage_ActualArea CStr(filePath), tmpBmp, ws, topLeft, w, h, cellPx

    ActiveWindow.DisplayHeadings = False
    MsgBox "완료! 왼쪽은 픽셀아트, 오른쪽은 실제 이미지 영역만큼의 원본이 배치되었습니다.", vbInformation

CleanExit:
    On Error Resume Next
    If Len(Dir$(tmpBmp)) > 0 Then Kill tmpBmp
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

'===========================================
'  WIA 사용: 이미지 리사이즈 + 24bpp BMP로 변환 (Late Binding)
'===========================================
Private Function WIA_ScaleAndSaveAsBMP(ByVal srcPath As String, ByVal dstBmp As String, _
                                       ByVal outW As Long, ByVal outH As Long) As Boolean
    On Error GoTo EH
    Dim img As Object           ' WIA.ImageFile
    Dim ip As Object            ' WIA.ImageProcess
    Dim resultImg As Object     ' WIA.ImageFile
    Const wiaFormatBMP As String = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"

    Set img = CreateObject("WIA.ImageFile")
    img.LoadFile srcPath

    Set ip = CreateObject("WIA.ImageProcess")

    ' 1) Scale (비율 유지)
    ip.Filters.Add ip.FilterInfos("Scale").FilterID
    ip.Filters(1).Properties("MaximumWidth").Value = outW
    ip.Filters(1).Properties("MaximumHeight").Value = outH

    ' 2) Convert → BMP 24bpp
    ip.Filters.Add ip.FilterInfos("Convert").FilterID
    ip.Filters(2).Properties("FormatID").Value = wiaFormatBMP
    On Error Resume Next
    ip.Filters(2).Properties("BitsPerPixel").Value = 24
    On Error GoTo EH

    Set resultImg = ip.Apply(img)
    resultImg.SaveFile dstBmp

    WIA_ScaleAndSaveAsBMP = True
    Exit Function
EH:
    WIA_ScaleAndSaveAsBMP = False
End Function

'===========================================
'  그리드 준비: 셀 크기/범위 초기화 (좌측 픽셀아트 영역)
'===========================================
Private Sub PrepareSquareGrid(ByVal ws As Worksheet, ByVal topLeft As Range, _
                              ByVal w As Long, ByVal h As Long, ByVal cellPx As Long)
    Dim r As Long, c As Long
    Dim colWidth As Double, rowHeight As Double

    ' 경험치 기반 변환: 1 colWidth ? 7.5 px, 1 px ? 0.75 pt
    colWidth = cellPx / 7.5
    rowHeight = cellPx * 0.75

    ' 대상 범위 색/서식 초기화
    ws.Range(topLeft, topLeft.Offset(h - 1, w - 1)).ClearFormats

    ' 열/행 크기 조정(좌측 픽셀아트 영역)
    For c = 0 To w - 1
        ws.Columns(topLeft.Column + c).ColumnWidth = colWidth
    Next c
    For r = 0 To h - 1
        ws.Rows(topLeft.Row + r).rowHeight = rowHeight
    Next r
End Sub

'===========================================
'  BMP → 셀 채우기 (실제 이미지 영역만 칠하고, 남는 영역 비우기)
'===========================================
Private Sub PaintCellsFromBitmap(ByVal bmpPath As String, ByVal ws As Worksheet, _
                                 ByVal topLeft As Range, ByVal w As Long, ByVal h As Long)
    On Error GoTo EH

    Dim pic As IPictureDisp
#If VBA7 Then
    Dim hBmp As LongPtr, hMemDC As LongPtr, hOld As LongPtr
#Else
    Dim hBmp As Long, hMemDC As Long, hOld As Long
#End If
    Dim x As Long, y As Long, yy As Long
    Dim colorref As Long, rr As Long, gg As Long, bb As Long
    Dim tgt As Range
    Dim bmpW As Long, bmpH As Long
    Dim drawW As Long, drawH As Long
    Dim yFlip As Boolean: yFlip = False  ' 필요 시 True

    ' BMP 로드 및 실제 픽셀 크기 계산(HIMETRIC → Pixel 변환)
    Set pic = LoadPicture(bmpPath)               ' StdPicture (IPictureDisp)
    bmpW = HiMetricToPixels(pic.Width, True)     ' 실제 BMP 폭(픽셀)
    bmpH = HiMetricToPixels(pic.Height, False)   ' 실제 BMP 높이(픽셀)

    ' 실제 그릴 영역 (입력 w/h와 BMP 실제 크기 중 작은 값)
    drawW = IIf(w < bmpW, w, bmpW)
    drawH = IIf(h < bmpH, h, bmpH)

#If VBA7 Then
    hBmp = pic.Handle
#Else
    hBmp = CLng(pic.Handle)
#End If

    hMemDC = CreateCompatibleDC(0)
    hOld = SelectObject(hMemDC, hBmp)

    ' 1) 실제 이미지 영역만 칠하기
    For y = 0 To drawH - 1
        yy = IIf(yFlip, (drawH - 1 - y), y)
        For x = 0 To drawW - 1
            colorref = GetPixel(hMemDC, x, yy)  ' COLORREF = 0x00BBGGRR
            Set tgt = ws.Cells(topLeft.Row + y, topLeft.Column + x)
            If colorref = &HFFFFFFFF Then
                tgt.Interior.Pattern = xlNone
            Else
                rr = (colorref And &HFF&)
                gg = (colorref \ &H100&) And &HFF&
                bb = (colorref \ &H10000) And &HFF&
                tgt.Interior.Color = RGB(rr, gg, bb)
            End If
        Next x
    Next y

    ' 2) 남는 영역 전부 흰색(배경용)
    If drawW < w Then
        ws.Range( _
            ws.Cells(topLeft.Row, topLeft.Column + drawW), _
            ws.Cells(topLeft.Row + drawH - 1, topLeft.Column + w - 1) _
        ).Interior.Color = vbWhite
    End If
    If drawH < h Then
        ws.Range( _
            ws.Cells(topLeft.Row + drawH, topLeft.Column), _
            ws.Cells(topLeft.Row + h - 1, topLeft.Column + w - 1) _
        ).Interior.Color = vbWhite
    End If

    ' 원복 & 정리
    Call SelectObject(hMemDC, hOld)
    Call DeleteDC(hMemDC)
    Exit Sub

EH:
    On Error Resume Next
    If hOld <> 0 Then SelectObject hMemDC, hOld
    If hMemDC <> 0 Then DeleteDC hMemDC
    MsgBox "셀 채우기 중 오류가 발생했습니다: " & Err.Description, vbExclamation
End Sub

'===========================================
'  (우측) 실제 이미지 영역(drawW×drawH)에만 원본 배치
'  - 픽셀아트 영역 오른쪽에 1열 공백 후 시작
'  - tmpBmp 크기를 읽어 drawW, drawH 산출 → 그 크기만큼만 배치
'===========================================
Private Sub PlaceOriginalImage_ActualArea(ByVal imgPath As String, ByVal tmpBmp As String, _
                                          ByVal ws As Worksheet, ByVal topLeft As Range, _
                                          ByVal w As Long, ByVal h As Long, ByVal cellPx As Long)
    Dim startCell As Range, panelArea As Range, imgArea As Range
    Dim c As Long, r As Long
    Dim colWidth As Double, rowHeight As Double
    Dim shp As Shape
    Dim startCol As Long
    Dim pic As IPictureDisp
    Dim bmpW As Long, bmpH As Long
    Dim drawW As Long, drawH As Long

    ' tmpBmp(축소 결과)의 실제 픽셀 크기로 drawW/drawH 산출
    Set pic = LoadPicture(tmpBmp)
    bmpW = HiMetricToPixels(pic.Width, True)
    bmpH = HiMetricToPixels(pic.Height, False)
    drawW = IIf(w < bmpW, w, bmpW)
    drawH = IIf(h < bmpH, h, bmpH)

    ' 동일한 셀 크기로 오른쪽 패널(공백 1열 + 원본용 패널 w열) 준비
    colWidth = cellPx / 7.5
    rowHeight = cellPx * 0.75

    startCol = topLeft.Column + w + 1                 ' 한 칸 띄운 다음 열부터
    ' 공백 1열 + 패널 w열까지 폭 세팅
    For c = 0 To w
        ws.Columns(startCol - 1 + c).ColumnWidth = colWidth
    Next c
    For r = 0 To h - 1
        ws.Rows(topLeft.Row + r).rowHeight = rowHeight
    Next r

    ' 패널 전체(w×h)
    Set startCell = ws.Cells(topLeft.Row, startCol)
    Set panelArea = ws.Range(startCell, startCell.Offset(h - 1, w - 1))
    ' 실제 이미지 영역(drawW×drawH)만 사용 (패널의 좌상단부터)
    Set imgArea = ws.Range(startCell, startCell.Offset(drawH - 1, drawW - 1))

    ' 패널 바탕은 흰색, 실제 이미지 영역은 그림으로 채움
    panelArea.Interior.Color = vbWhite

    ' 기존 그림 겹침 방지(필요 시 사용)
    'Dim s As Shape
    'For Each s In ws.Shapes
    '    If s.Left >= panelArea.Left - 0.5 And s.Top >= panelArea.Top - 0.5 _
    '       And s.Left < panelArea.Left + panelArea.Width And s.Top < panelArea.Top + panelArea.Height Then
    '        s.Delete
    '    End If
    'Next s

    ' 원본 이미지 삽입: '실제 이미지 영역' 크기에 맞춰 배치
    Set shp = ws.Shapes.AddPicture(CStr(imgPath), msoFalse, msoTrue, _
                                   imgArea.Left, imgArea.Top, imgArea.Width, imgArea.Height)
    On Error Resume Next
    shp.LockAspectRatio = msoFalse          ' drawW:drawH 셀 비율과 동일하므로 왜곡 없음
    shp.Placement = xlMoveAndSize
    On Error GoTo 0
End Sub

'===========================================
'  화면 DPI 및 HIMETRIC → Pixel 변환 유틸
'===========================================
Private Function ScreenDPI(Optional ByVal isX As Boolean = True) As Long
#If VBA7 Then
    Dim hdc As LongPtr
#Else
    Dim hdc As Long
#End If
    hdc = GetDC(0)
    If isX Then
        ScreenDPI = GetDeviceCaps(hdc, LOGPIXELSX)
    Else
        ScreenDPI = GetDeviceCaps(hdc, LOGPIXELSY)
    End If
    Call ReleaseDC(0, hdc)
    If ScreenDPI = 0 Then ScreenDPI = 96 ' 폴백
End Function

Private Function HiMetricToPixels(ByVal hm As Long, Optional ByVal isX As Boolean = True) As Long
    ' 1 inch = 25.4 mm = 2540 HIMETRIC(0.01mm 단위)
    HiMetricToPixels = CLng((hm * ScreenDPI(isX) + 1270) \ 2540)
End Function

사진을 Pixel Art로 변환.xlsm

0.37MB

셀 클릭하면 자동 완성창이 뜬다고? 이게 진짜 됩니다.

노만e — Thu, 7 Aug 2025 22:03:48 +0900

엑셀 자동완성, 네이버 검색창처럼 만드는 방법

엑셀에서도 자동완성 기능이 있었으면 하고, 생각해 보신적은 없으신가요?

오늘은 "셀 클릭 → 자동완성창 표시 → 키보드 입력에 따라 자동 추천"이 가능한 고급 자동입력 기능을 만들어보려 합니다.
심지어 ESC 키로 취소하거나, Enter 키로 다음 셀로 자동 이동하는 UX까지 구현됩니다.

핵심 기능 정리:

✔ 특정 셀(C열 2행 이후)을 클릭하면 콤보박스 자동 표시
✔ List 시트에서 데이터를 불러와 자동완성 리스트 생성
✔ 입력 중 일부만 타이핑해도 자동으로 후보 리스트 필터링
✔ Enter로 값 확정 및 다음 셀 이동
✔ ESC로 입력 취소 및 이전 셀 이동
✔ ← → 방향키도 대응하여 콤보박스 자동 종료

복잡해 보이지만, 본문 코드 그대로 붙여넣고 몇 줄만 수정하면 여러분 엑셀에서도 완벽하게 작동합니다.

드롭다운보다 빠르고, 검색창처럼 유연한 자동완성.
엑셀 실무자라면 반드시 알아야 할 고급 기능입니다.

아래 코드로 직접 구현해보세요!

Option Explicit
Dim lis() As Variant
Dim memo As Variant
Dim ws As Worksheet
Dim isEscPressed As Boolean  ' ESC 키 눌림 상태 추적

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  ' 다중 셀 선택시 콤보박스 숨기고 종료
  If Target.CountLarge > 1 Then
    Me.ComboBox1.Visible = False
    Exit Sub
  End If

  ' D3 이후 행에서만 동작하도록 수정
  If Target.Column <> 3 Or Target.Row <= 1 Then
    Me.ComboBox1.Visible = False
    Exit Sub
  End If

  Dim zInput As Range

  Set ws = Sheets("List")
  Set zInput = Target

  If Target.Count = 1 Then
    isEscPressed = False  ' 새로운 셀 선택시 ESC 상태 초기화
    If memo <> "" Then
      If IsError(Application.Match(Range(memo), lis, 0)) Then Range(memo) = ""
    End If

    ' List 시트의 A2열부터 데이터 가져오기
    lis = Application.Transpose(ws.Range("A2:A" & ws.[A65000].End(xlUp).Row))
    Me.ComboBox1.List = lis
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
    memo = Target.Address
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub

Private Sub ComboBox1_Change()
  ' 다중 셀 선택시 종료
  If Selection.CountLarge > 1 Then Exit Sub

  Dim dic
  Dim tmp As String
  Dim c As Variant

  ' ESC 키가 눌렸으면 값 입력하지 않음
  If isEscPressed Then Exit Sub

  If Me.ComboBox1 <> "" And IsError(Application.Match(Me.ComboBox1, lis, 0)) Then
    Set dic = CreateObject("Scripting.Dictionary")
    tmp = UCase(Me.ComboBox1) & "*"
    For Each c In lis
      If UCase(c) Like tmp Then dic(c) = ""
    Next c
    Me.ComboBox1.List = dic.keys
    Me.ComboBox1.DropDown
  End If
  ActiveCell.Value = Me.ComboBox1
End Sub

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  ' 다중 셀 선택시 종료
  If Selection.CountLarge > 1 Then Exit Sub

  ' List 시트의 A2열부터 데이터 가져오기
  ComboBox1.List = Application.Transpose(ws.Range("A2:A" & ws.[A65000].End(xlUp).Row))
  Me.ComboBox1.DropDown
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  ' 다중 셀 선택시 종료
  If Selection.CountLarge > 1 Then Exit Sub

  If KeyCode = 13 Then  ' Enter 키
    isEscPressed = False  ' ESC 상태 초기화
    If IsError(Application.Match(ActiveCell, lis, 0)) Then ActiveCell = ""
    Me.ComboBox1.Visible = False
    ActiveCell.Offset(1).Select  ' 아래 셀로 이동
    ' 아래 셀이 D열이고 3행 이후라면 콤보박스 다시 표시
    If ActiveCell.Column = 4 And ActiveCell.Row >= 3 Then
      Call Worksheet_SelectionChange(ActiveCell)
    End If

  ElseIf KeyCode = 27 Then  ' ESC 키
    isEscPressed = True
    Me.ComboBox1.Visible = False
    ActiveCell.Value = ""
    ActiveCell.Offset(, -1).Select

    isEscPressed = False

  ElseIf KeyCode = 37 Or KeyCode = 39 Then  ' ← 또는 → 키
    Me.ComboBox1.Visible = False
    If KeyCode = 37 Then  ' ←
        ActiveCell.Offset(, -1).Select
    ElseIf KeyCode = 39 Then  ' →
        ActiveCell.Offset(, 1).Select
    End If

  ElseIf KeyCode = 27 Then  ' ESC 키
    isEscPressed = True  ' ESC 키 눌림 상태 설정
    Me.ComboBox1.Visible = False
    ' C열의 같은 행으로 이동
    ActiveCell.Value = ActiveCell.Value
    ActiveCell.Offset(, -1).Select
    ActiveCell.Value = ""
    isEscPressed = False  ' ESC 상태 초기화
  End If
End Sub

Private Sub ComboBox1_LostFocus()
On Error Resume Next
' 다중 셀 선택시 종료
  If Selection.CountLarge > 1 Then
    Me.ComboBox1.Visible = False
    Exit Sub
  End If

  ' ? 현재 셀이 memo(콤보박스를 띄웠던 셀)와 다르면 값 입력하지 않음
  If Not Intersect(ActiveCell, Range(memo)) Is Nothing Then
    ActiveCell.Value = Me.ComboBox1
  End If

  Me.ComboBox1.Visible = False

  ' 현재 셀이 C열 2행 이후라면 콤보박스 다시 표시
  If ActiveCell.Column = 3 And ActiveCell.Row >= 2 Then
    Application.EnableEvents = False
    Application.EnableEvents = True
    Call Worksheet_SelectionChange(ActiveCell)
  End If
End Sub

문자열 자동완성_콤보박스_최종.xlsm

모든 워크시트의 개체 한 번에 삭제하는 VBA 코드 공개합니다

노만e — Wed, 6 Aug 2025 23:15:15 +0900

엑셀 작업 중 워크시트마다 복사된 버튼, 도형, 차트, OLE 개체들이 누적되면서 작업 속도가 느려지거나 컴퓨터가 다운된 경험 있으신가요?

오늘은 **"모든 시트의 개체를 한 번에 삭제하는 VBA 자동화 코드"**를 소개합니다.
단순한 도형 삭제 수준이 아니라, 사진을 제외한 도형 / ActiveX / 차트 / 주석 등 실무에서 문제되는 개체들을 전부 정리합니다.

✅ 어떤 상황에서 유용할까요?

여러 시트를 복사하다가 정체불명의 개체가 생겼을 때
템플릿 문서를 자동화할 때 초기화용으로 사용
배포 전, 보고서 파일을 가볍게 만들고 싶을 때

핵심 기능 요약

✔ 모든 시트를 순회하며
✔ 도형(사진 제외), OLE 개체, 차트, 주석 등을
✔ 단 1번 실행으로 전부 삭제

VBA 코드 전체

Sub AllShapeDelete()
    '모든 워크시트의 개체를 삭제하는 메인 프로시저
    Dim ws As Worksheet
    Dim result As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    result = "개체 삭제 결과:" & vbCrLf & vbCrLf

    For Each ws In ActiveWorkbook.Worksheets
        result = result & "워크시트: " & ws.Name & vbCrLf
        result = result & 워크시트개체삭제(ws) & vbCrLf & vbCrLf
    Next ws

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox result, vbInformation, "개체 삭제 완료"
End Sub

Function 워크시트개체삭제(ws As Worksheet) As String
    '특정 워크시트의 모든 개체를 삭제하는 함수
    Dim deleteCount As Long
    Dim totalCount As Long
    Dim result As String

    deleteCount = 0

    '1. Shapes 컬렉션을 통한 일반 도형 삭제
    deleteCount = deleteCount + Shapes컬렉션삭제(ws)

    '2. DrawingObjects를 통한 삭제 (Shapes로 접근 불가능한 개체 포함)
    deleteCount = deleteCount + DrawingObjects삭제(ws)

    '3. OLEObjects 삭제 (ActiveX 컨트롤, 삽입된 개체 등)
    deleteCount = deleteCount + OLEObjects삭제(ws)

    '4. ChartObjects 삭제 (차트)
    deleteCount = deleteCount + ChartObjects삭제(ws)

    '5. Comments 삭제 (주석)
    deleteCount = deleteCount + Comments삭제(ws)

    result = "  삭제된 개체 수: " & deleteCount & "개"

    워크시트개체삭제 = result
End Function

Function Shapes컬렉션삭제(ws As Worksheet) As Long
    'Shapes 컬렉션을 통한 도형 삭제 (사진 제외)
    Dim shp As Shape
    Dim deleteCount As Long

    On Error Resume Next

    '역순으로 삭제 (컬렉션 인덱스 변화 방지)
    For i = ws.Shapes.Count To 1 Step -1
        Set shp = ws.Shapes(i)
        If Not shp Is Nothing Then
            '사진 타입은 제외하고 삭제
            If shp.Type <> msoPicture Then
                shp.Delete
                deleteCount = deleteCount + 1
            End If
        End If
    Next i

    On Error GoTo 0
    Shapes컬렉션삭제 = deleteCount
End Function

Function DrawingObjects삭제(ws As Worksheet) As Long
    'DrawingObjects를 통한 삭제 (구버전 호환성, 사진 제외)
    Dim deleteCount As Long
    Dim obj As Object

    On Error Resume Next

    '개별 개체를 확인하여 사진이 아닌 경우만 삭제
    For i = ws.DrawingObjects.Count To 1 Step -1
        Set obj = ws.DrawingObjects(i)
        If Not obj Is Nothing Then
            '사진이 아닌 경우만 삭제 (TypeName으로 구분)
            If TypeName(obj) <> "Picture" Then
                obj.Delete
                deleteCount = deleteCount + 1
            End If
        End If
    Next i

    On Error GoTo 0
    DrawingObjects삭제 = deleteCount
End Function

Function OLEObjects삭제(ws As Worksheet) As Long
    'OLE 개체 삭제 (ActiveX 컨트롤, 삽입된 파일 등)
    Dim oleObj As OLEObject
    Dim deleteCount As Long

    On Error Resume Next

    For i = ws.OLEObjects.Count To 1 Step -1
        Set oleObj = ws.OLEObjects(i)
        If Not oleObj Is Nothing Then
            oleObj.Delete
            deleteCount = deleteCount + 1
        End If
    Next i

    On Error GoTo 0
    OLEObjects삭제 = deleteCount
End Function

Function ChartObjects삭제(ws As Worksheet) As Long
    '차트 개체 삭제
    Dim chartObj As ChartObject
    Dim deleteCount As Long

    On Error Resume Next

    For i = ws.ChartObjects.Count To 1 Step -1
        Set chartObj = ws.ChartObjects(i)
        If Not chartObj Is Nothing Then
            chartObj.Delete
            deleteCount = deleteCount + 1
        End If
    Next i

    On Error GoTo 0
    ChartObjects삭제 = deleteCount
End Function

Function Comments삭제(ws As Worksheet) As Long
    '주석 삭제
    Dim deleteCount As Long
    Dim rng As Range

    On Error Resume Next

    For Each rng In ws.UsedRange
        If Not rng.Comment Is Nothing Then
            rng.Comment.Delete
            deleteCount = deleteCount + 1
        End If
    Next rng

    On Error GoTo 0
    Comments삭제 = deleteCount
End Function

실전 팁

사진은 보존됩니다: 보고서용 이미지, 스크린샷은 유지됨
주석도 삭제됩니다: 수기로 남긴 메모가 있다면 주의
코드 실행 전, 파일 백업 권장

현재 파일의 모든 개체 삭제.xlsm

Excel VBA로 과일 판매 데이터 피벗테이블 자동 생성하기

노만e — Thu, 31 Jul 2025 21:37:20 +0900

피벗테이블 만들기

Excel에서 피벗테이블을 수동으로 만드는 것도 좋지만, VBA를 사용하면 한 번의 클릭으로 전문적인 피벗테이블을 자동으로 생성할 수 있습니다. 오늘은 판매점별 과일 판매금액을 분석하는 피벗테이블을 VBA로 만드는 방법을 알아보겠습니다.

개요

이 VBA 코드는 다음과 같은 기능을 제공합니다:

✅ 자동 데이터 감지: 과일시트의 데이터를 자동으로 찾아서 피벗테이블 생성
✅ 전문적인 레이아웃: 행(판매점명) × 열(과일명) × 데이터(판매금액 합계)
✅ 통계 정보 추가: 총 판매점 수, 과일 종류, 판매금액 등 요약 통계
✅ 깔끔한 서식: 자동 스타일링과 숫자 포맷 적용

준비사항

1. 데이터 준비

Excel 파일에 "과일시트" 이름의 워크시트를 만들고, 다음과 같은 형태의 데이터를 준비해주세요:

번호판매점명과일명단가(원)수량(개)판매금액(원)

1	이마트 강남점	사과	2000	5	10000
2	롯데마트 잠실점	바나나	1500	3	4500
...	...	...	...	...	...

2. 필수 컬럼

판매점명: 피벗테이블의 행 필드
과일명: 피벗테이블의 열 필드
판매금액(원): 피벗테이블의 데이터 필드 (합계)

사용방법

Step 1: VBA 편집기 열기

Excel에서 Alt + F11 키를 눌러 VBA 편집기를 엽니다
왼쪽 프로젝트 창에서 해당 통합문서를 선택합니다

Step 2: 새 모듈 추가

메뉴에서 삽입(Insert) → 모듈(Module) 클릭
새로운 코드 창이 열립니다

Step 3: 코드 붙여넣기

제공된 VBA 코드를 전체 복사해서 모듈 창에 붙여넣습니다.

Step 4: 매크로 실행

Alt + F8 키를 눌러 매크로 대화상자를 엽니다
CreateFruitSalesPivotTable 매크로를 선택합니다
실행 버튼을 클릭합니다

Step 5: 결과 확인

새로운 "PivotTable" 워크시트가 생성됩니다
A1셀에 "판매점별 과일판매금액" 제목이 표시됩니다
A3셀부터 피벗테이블이 시작됩니다

코드 주요 기능 설명

자동 데이터 소스 설정

vba

Set ws = Worksheets("과일시트")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set dataRange = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))

"과일시트"에서 데이터를 자동으로 감지합니다
마지막 행까지 자동으로 범위를 설정합니다

피벗테이블 구조 설정

vba

.PivotFields("판매점명").Orientation = xlRowField
.PivotFields("과일명").Orientation = xlColumnField
.PivotFields("판매금액(원)").Orientation = xlDataField

행: 판매점명 (세로축)
열: 과일명 (가로축)
데이터: 판매금액 합계

자동 서식 적용

vba

.TableStyle2 = "PivotStyleMedium9"
.NumberFormat = "#,##0"

전문적인 피벗테이블 스타일 적용
숫자에 천 단위 구분 기호 자동 적용

통계 정보 자동 생성

총 판매점 수
총 과일 종류
전체 판매금액
평균 판매금액
업데이트 시간

⚠️ 주의사항

1. 시트명 확인

데이터가 있는 시트의 이름이 정확히 **"과일시트"**여야 합니다
시트명이 다르면 오류가 발생합니다

2. 컬럼명 확인

"판매점명", "과일명", "판매금액(원)" 컬럼명이 정확해야 합니다
첫 번째 행에 헤더가 있어야 합니다

3. 기존 시트 덮어쓰기

이미 "PivotTable" 시트가 있으면 자동으로 삭제 후 새로 생성됩니다
기존 데이터를 보존하려면 시트명을 미리 변경해두세요

4. 데이터 형식

판매금액은 숫자 형식이어야 합니다
텍스트로 입력된 숫자는 합계 계산이 안 될 수 있습니다

추가 활용 팁

피벗테이블 새로고침

데이터가 변경되었을 때는 RefreshPivotTable() 매크로를 실행하세요:

vba

Sub RefreshPivotTable()
    Dim pt As PivotTable
    For Each pt In ActiveSheet.PivotTables
        pt.PivotCache.Refresh
    Next pt
    MsgBox "피벗테이블이 새로고침되었습니다.", vbInformation
End Sub

스타일 변경

ChangePivotTableStyle() 매크로로 피벗테이블 색상을 변경할 수 있습니다:

파란색, 녹색, 주황색 등 다양한 스타일 제공

다른 데이터에 응용

이 코드는 다음과 같이 응용할 수 있습니다:

지역별 × 제품별 판매 분석
월별 × 카테고리별 매출 분석
고객별 × 상품별 구매 패턴 분석

컬럼명만 적절히 수정하면 다양한 데이터 분석에 활용 가능합니다!

마무리

VBA를 활용하면 복잡한 피벗테이블도 한 번의 클릭으로 생성할 수 있습니다. 특히 정기적으로 같은 형태의 분석을 해야 하는 경우, 이런 자동화 코드가 큰 도움이 됩니다.

Sub CreateFruitSalesPivotTable()
    '변수 선언
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim pc As PivotCache
    Dim dataRange As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim pivotWs As Worksheet

    '과일시트를 데이터 소스로 설정
    On Error Resume Next
    Set ws = Worksheets("과일시트")
    On Error GoTo 0

    '데이터 범위 자동 감지
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Set dataRange = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))

    '데이터 유효성 검사
    If ws Is Nothing Then
        MsgBox "과일시트를 찾을 수 없습니다. 시트명을 확인해주세요.", vbExclamation
        Exit Sub
    End If

    If lastRow < 2 Then
        MsgBox "데이터가 충분하지 않습니다. 최소 2행 이상의 데이터가 필요합니다.", vbExclamation
        Exit Sub
    End If

    '새 워크시트 생성 (피벗테이블용)
    '기존 PivotTable 시트가 있으면 삭제
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("PivotTable").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set pivotWs = Worksheets.Add
    pivotWs.Name = "PivotTable"

    '피벗캐시 생성
    Set pc = ActiveWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=dataRange)

    '피벗테이블 생성 (A3 위치에)
    Set pt = pc.CreatePivotTable( _
        TableDestination:=pivotWs.Range("A3"), _
        TableName:="과일판매피벗테이블")

    '피벗테이블 필드 설정
    With pt
        '행 필드: 판매점명
        .PivotFields("판매점명").Orientation = xlRowField
        .PivotFields("판매점명").Position = 1

        '열 필드: 과일명
        .PivotFields("과일명").Orientation = xlColumnField
        .PivotFields("과일명").Position = 1

        '데이터 필드: 판매금액 (합계)
        With .PivotFields("판매금액(원)")
            .Orientation = xlDataField
            .Function = xlSum
            .Name = "판매금액 합계"
            .NumberFormat = "#,##0"
        End With

        '피벗테이블 스타일 및 옵션 설정
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
        .TableStyle2 = "PivotStyleMedium9"
        .ShowTableStyleRowStripes = True
        .ShowTableStyleColumnStripes = True

        '총합계 표시
        .PivotFields("판매점명").Subtotals(1) = True
        .ColumnGrand = True
        .RowGrand = True

        '필드 헤더 표시
        .DisplayFieldCaptions = True
    End With

    '워크시트 서식 설정
    With pivotWs
        '제목 추가 (1행에)
        .Range("A1").Value = "판매점별 과일판매금액"
        .Range("A1").Font.Size = 14
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Color = RGB(68, 114, 196)

        '열 너비 자동 조정
        .Columns.AutoFit

        '첫 번째 열 고정 (A3 기준)
        .Range("B3").Select
        ActiveWindow.FreezePanes = True
    End With

    '추가 통계 정보 생성
    Call AddSummaryStats(pivotWs, pt)

    '완료 메시지
    MsgBox "피벗테이블이 성공적으로 생성되었습니다!" & vbNewLine & _
           "워크시트: PivotTable" & vbNewLine & _
           "행: 판매점명" & vbNewLine & _
           "열: 과일명" & vbNewLine & _
           "데이터: 판매금액 합계", vbInformation, "피벗테이블 생성 완료"

    '생성된 워크시트 활성화
    pivotWs.Activate
    pivotWs.Range("A3").Select
End Sub

과일판매데이터_2025-07-31.xlsm

이미지_다운로더_최종 - ver1.0.xlsm

엑셀 VBA로 네이버 검색 이미지 1000장 자동 다운로드하기 | 2025년 완벽 가이드

노만e — Tue, 29 Jul 2025 23:04:43 +0900

주요 기능

1. 이미지 다운로드 + 셀 삽입

네이버에서 이미지 검색 및 다운로드
다운로드 완료된 이미지를 F열부터 순서대로 셀에 자동 삽입

2. 셀 크기 자동 조정

행 높이: 100픽셀
열 너비: 15 단위
이미지가 셀 크기에 맞게 자동 조정

3. 스마트 이미지 관리

기존 이미지 자동 삭제 후 새 이미지 삽입
이미지별 고유한 이름 부여 (Image_행번호_열번호)
여백 1픽셀로 깔끔한 정렬

엑셀 시트 구성

A열B열C열F열G열H열...

키워드	수량	저장경로	이미지1	이미지2	이미지3	...
강아지	5	C:\Images	️	️	️	️
고양이	3	C:\Images	️	️	️

✨ 동작 과정

A2, B2, C2 값 읽기 (키워드, 수량, 저장경로)
폴더 생성 (키워드명으로, 중복시 숫자 추가)
네이버에서 이미지 검색 및 다운로드
다운로드 성공한 이미지 경로를 배열에 저장
F열부터 순서대로 셀에 이미지 삽입
다음 행(A3, B3, C3...)으로 이동하여 반복

사용 팁

셀 크기 조정: 코드의 RowHeight = 100, ColumnWidth = 15 값을 변경하여 원하는 크기로 조정 가능
이미지 시작 열 변경: startCol = 6 (F열)을 다른 숫자로 변경하여 시작 위치 조정 가능
여백 조정: Width = currentCell.Width - 2 에서 숫자를 변경하여 이미지와 셀 간 여백 조정

이제 이미지를 다운로드하면서 동시에 엑셀 시트에서 바로 미리보기가 가능합니다!

⚡ 5분만에 마스터하는 이미지 자동 수집의 비밀

상상해보세요! 마케팅 자료를 위해 하루 종일 이미지를 하나씩 저장하던 당신이, 이제 키워드 하나만 입력하면 1000장의 이미지가 자동으로 폴더별로 정리되고 엑셀에까지 깔끔하게 정렬되는 모습을요!

이 가이드로 얻을 수 있는 것들

✅ 네이버 이미지 API 완벽 활용법
✅ VBA로 폴더 자동 생성 및 중복 처리
✅ 엑셀 셀에 이미지 자동 삽입 기술
✅ 복사 붙여넣기만으로 바로 사용 가능한 완성 코드
✅ 업무 효율 1000% 향상 노하우

누구에게 필요한가요?

마케터, 디자이너, 콘텐츠 제작자, 연구원이라면 이 가이드가 게임 체인저가 될 것입니다!

디자이너: 레퍼런스 이미지 대량 수집
마케터: 경쟁사 제품 이미지 분석
블로거: 포스팅용 이미지 자동 수집
연구원: 데이터 수집 자동화

왜 이 방법이 특별한가요?

기존의 이미지 다운로드 도구들과 달리, 이 VBA 솔루션은:

완전 자동화: 키워드만 입력하면 끝
스마트 정리: 폴더 자동 생성 및 중복 처리
엑셀 연동: 다운로드와 동시에 셀에 삽입
⚡ 빠른 속도: 한 번에 1000장까지 처리
완전 무료: 별도 프로그램 설치 불필요

️ 필요한 준비물

Microsoft Excel (VBA 지원 버전)
인터넷 연결
5분의 시간 ⏰

단계별 구현 가이드

1단계: 엑셀 시트 설정

A열: 검색 키워드 입력
B열: 다운로드할 이미지 수량
C열: 저장할 폴더 경로
F열~: 다운로드된 이미지가 자동 삽입될 영역

2단계: 마법 실행

매크로를 실행하면 자동으로:

네이버에서 키워드 검색
키워드명으로 폴더 생성
⬇️ 이미지 자동 다운로드
엑셀 셀에 이미지 정렬

⚠️ 주의사항 및 팁

과도한 요청 방지: 한 번에 너무 많은 이미지 요청 시 IP 차단 가능
저장 공간 확인: 대용량 이미지 다운로드 전 디스크 용량 체크

마무리

이제 몇 시간씩 걸리던 이미지 수집 작업이 단 몇 분으로 단축됩니다! 이 가이드가 여러분의 업무 효율성을 크게 향상시켜 드릴 것입니다.

이 가이드가 도움이 되셨나요? 댓글로 여러분의 성공 사례를 공유해주세요! 더 많은 자동화 팁이 궁금하시다면 구독과 좋아요 부탁드립니다!

2.47MB

엑셀에서 구글 번역기를 바로?

노만e — Sun, 27 Jul 2025 16:26:29 +0900

영어 번역 함수

엑셀에서 구글 번역기를 바로? 셀에 입력만 하면 자동 번역되는 마법의 VBA 함수!

안녕하세요! 엑셀로 해외 문서 작업을 하거나, 한글로 된 데이터를 영어로 빠르게 변환해야 할 때마다 번역기를 따로 열고, 복사-붙여넣기를 반복하느라 시간을 낭비하고 계신가요? 이제 그럴 필요 없습니다!

오늘 소개해 드릴 엑셀 VBA 함수는 여러분의 엑셀 시트에 구글 번역기 기능을 그대로 옮겨 놓은 듯한 마법을 선사합니다. 셀에 한글을 입력하고 옆 셀에 함수만 입력하면, 실시간으로 영문 번역 결과를 바로 확인할 수 있습니다. 이 강력한 기능으로 여러분의 업무 효율을 극대화해 보세요!

이 번역 함수, 무엇이 특별할까요?

✨ 셀에서 바로 사용: 엑셀 시트의 어떤 셀이든 =TranslateToEnglish(셀주소)처럼 입력하면 즉시 번역됩니다.
모든 시트에서 사용 가능: 한 번만 설정해두면 현재 통합 문서의 모든 시트에서 이 함수를 자유롭게 사용할 수 있습니다.
빠른 번역: 구글 번역 API를 활용하여 빠르고 정확한 번역 결과를 제공합니다.
⏰ 시간 절약: 번역기와 엑셀을 오가는 번거로움 없이 한 곳에서 모든 작업을 처리할 수 있습니다.

엑셀 자동 번역 함수 사용 방법 가이드

이 함수를 사용하기 위한 단계는 매우 간단합니다. 한 번만 설정해두면 영구적으로 사용할 수 있습니다.

1단계: VBA 편집기 열기

엑셀 파일을 열고 키보드의 Alt + F11 키를 동시에 누릅니다.
'Microsoft Visual Basic for Applications' 편집기 창이 열립니다.

2단계: '표준 모듈' 삽입

VBA 편집기 왼쪽 상단의 '프로젝트 탐색기' 창에서 현재 작업 중인 엑셀 파일 이름(VBAProject (현재 파일 이름.xlsm))을 찾습니다.
해당 파일 이름을 마우스 오른쪽 버튼으로 클릭합니다.
팝업 메뉴에서 삽입(I) > 모듈(M)을 선택합니다.
중요: 'Sheet1 (Sheet1)'이나 'ThisWorkbook' 같은 시트 이름이 아닌, **'모듈(Module)'**이라고만 되어 있는 새로운 창이 열려야 합니다.

3단계: 코드 복사 및 붙여넣기

새로 열린 '모듈' 창에 아래의 VBA 코드를 모두 복사하여 붙여넣습니다.

4단계: 엑셀 시트에서 함수 사용하기

VBA 편집기를 닫고 엑셀 시트로 돌아옵니다.
번역을 원하는 한글 텍스트가 있는 셀 (예: A1)이 있다면, 번역 결과를 표시할 셀 (예: B1)에 다음과 같이 입력합니다. =TranslateToEnglish(A1)
Enter 키를 누르면 B1 셀에 A1 셀의 한글 텍스트가 영어로 번역되어 나타납니다.
채우기 핸들(셀의 오른쪽 아래 작은 사각형)을 드래그하여 여러 셀에 한 번에 함수를 적용할 수 있습니다.

⚠️ 꼭 알아두세요! (주의 사항)

이 편리한 함수를 사용하기 전에 몇 가지 중요한 주의 사항을 확인해 주세요.

인터넷 연결 필수: 이 함수는 구글 번역 API를 사용하므로, 엑셀을 사용하는 동안 인터넷 연결이 되어 있어야 합니다.
성능 저하 가능성: Application.Volatile 설정 때문에 셀 내용이 변경되거나 엑셀이 재계산될 때마다 웹 요청을 다시 보냅니다. 많은 셀에 이 함수를 사용하거나, 시트 내용이 자주 변경되는 경우 엑셀의 반응 속도가 다소 느려질 수 있습니다.
API 응답 형식 의존성: 현재 코드는 구글 번역 API의 특정 응답 형식을 기반으로 번역 결과를 추출합니다. 구글이 API 응답 형식을 변경할 경우, 이 함수가 더 이상 작동하지 않을 수 있습니다. (이 경우 코드를 수정해야 합니다.)
Excel 버전 호환성: 코드 내 WorksheetFunction.EncodeURL 함수는 Excel 2013 버전 이상에서만 정상적으로 작동합니다. 이전 버전의 Excel을 사용하시는 경우, URL 인코딩 부분에서 오류가 발생할 수 있습니다.
오류 메시지 확인: 번역에 실패하거나 HTTP 요청에 문제가 발생하면 셀에 "오류 발생: (오류 내용)" 또는 "HTTP 오류: (상태 코드)" 등의 메시지가 표시됩니다.
매크로 보안 설정: 엑셀 파일에 매크로가 포함되어 있으므로, 파일을 열 때 '보안 경고'가 나타날 수 있습니다. '콘텐츠 사용' 또는 '매크로 포함'을 허용해야 함수가 정상적으로 작동합니다.
위의 번역 함수를 사용후, 다른 곳에 보낼때는 [영어 번역]열의 셀 값을 값으로 붙여 넣은후, 보내주세요.

영문번역 함수 사용하기.xlsm

엑셀 파일을 서버처럼 사용하기

노만e — Sun, 27 Jul 2025 15:55:27 +0900

인사 정보 리스트

엑셀파일에서 원하는 데이터만 가져오기

엑셀 초보도 1분 만에 데이터 관리 끝! 인사 정보 자동 추출 매크로 완벽 가이드

안녕하세요! 엑셀 작업을 하다 보면 매번 반복되는 데이터 추출과 정리 작업에 지치셨나요? 수많은 직원 정보 중에서 원하는 데이터만 쏙쏙 뽑아내고, 깔끔하게 정리하는 일이 여간 귀찮은 게 아닙니다. 하지만 걱정 마세요! 오늘 소개해 드릴 엑셀 VBA 매크로만 있다면, 이 모든 과정을 단 1분 만에, 클릭 한 번으로 자동화할 수 있습니다.

이 매크로는 외부 엑셀 파일에 저장된 방대한 인사 정보에서 필요한 데이터를 자동으로 가져와 현재 시트에 보기 좋게 정리해 줍니다. 이제 더 이상 수작업으로 데이터를 찾아 헤매거나, 복사-붙여넣기 오류로 스트레스받을 필요가 없습니다!

인사 정보 추출 매크로, 무엇이 특별할까요?

이 매크로는 단순히 데이터를 가져오는 것을 넘어, 여러분의 엑셀 작업 효율을 극대화할 수 있도록 설계되었습니다.

⚡ 초고속 데이터 추출: 수만 건의 데이터도 조건에 맞춰 순식간에 가져옵니다.
유연한 조건 검색: 특정 팀, 특정 직급 등 원하는 조건에 맞춰 데이터를 필터링할 수 있습니다.
깔끔한 자동 정리: 가져온 데이터는 자동으로 번호가 매겨지고, 지정된 헤더와 함께 보기 좋게 정렬됩니다.
️ 안정적인 오류 처리: 데이터가 없거나 경로에 문제가 생겨도 오류 메시지를 통해 친절하게 알려줍니다.

이제 이 강력한 매크로를 어떻게 사용하는지 자세히 알아볼까요?

1분 만에 끝내는 사용 방법 가이드

이 매크로를 사용하려면 몇 가지 사전 설정이 필요하지만, 한 번만 해두면 다음부터는 클릭 한 번으로 모든 작업을 해결할 수 있습니다.

1. 준비물 확인하기

먼저 매크로가 제대로 작동하기 위한 필수 정보를 입력해야 합니다. 아래 그림처럼 엑셀 시트의 특정 셀에 정보를 입력해 주세요.

(블로그에 실제 엑셀 화면 스크린샷을 첨부하면 좋습니다. 아래는 셀 위치 설명입니다.)

D3 셀: 데이터를 가져올 외부 엑셀 파일의 전체 경로를 입력합니다.
- 예: C:\Users\YourName\Documents\인사 정보 리스트.xlsx
D5 셀: 외부 엑셀 파일에서 가져올 컬럼(열)의 이름을 쉼표(,)로 구분하여 입력합니다.
- 예: 이름,사원번호,부서,연락처,이메일
- 주의: 외부 엑셀 파일의 실제 컬럼 이름과 정확히 일치해야 합니다.
K5 셀 (선택 사항): 데이터를 필터링할 기준이 될 컬럼 이름을 입력합니다. (예: 부서 또는 팀명)
L5 셀 (선택 사항): K5에 입력한 컬럼에서 찾을 값을 입력합니다. (예: 영업팀 또는 개발팀)
- K5와 L5는 필터링이 필요할 때만 입력합니다. 이 두 셀이 비어있으면 모든 데이터를 가져옵니다.

2. 매크로 실행하기

모든 준비가 끝났다면, 이제 마법을 부릴 시간입니다!

[실행] 버튼
을 클릭합니다.

3. 결과 확인하기

매크로가 실행되면, 현재 엑셀 시트의 B9 셀부터 데이터를 가져와서 채워지는 것을 확인할 수 있습니다.

B9 셀에는 "No." 라는 헤더가 생성되고, 그 아래로 자동으로 번호가 매겨집니다.
C9 셀부터는 D5에 입력했던 순서대로 컬럼 헤더가 나타나고, 그 아래로 추출된 데이터가 깔끔하게 정렬됩니다.
K7 셀에는 총 인원수가 자동으로 계산되어 표시됩니다.

만약 조건에 맞는 데이터가 없다면, 친절하게 "조건에 맞는 데이터가 없습니다."라는 메시지 박스가 나타날 것입니다.

엑셀에서 벽돌을 깬다고?! 직장인 다 모여! 점심시간 순삭 게임 등장!

노만e — Wed, 23 Jul 2025 23:53:52 +0900

벽돌깨기 게임 화면

엑셀로 즐기는 추억의 벽돌깨기! 지루한 업무/공부 시간은 이제 그만!

안녕하세요! 매일 반복되는 업무와 공부에 지쳐 있지는 않으신가요? 잠시 머리 식힐 무언가가 필요할 때, 따분한 스프레드시트 화면이 눈에 밟힐 때! 이제 엑셀을 단순한 업무 도구로만 보지 마세요! 여러분의 엑셀을 짜릿한 오락실 게임기로 바꿔줄 특별한 매크로 게임을 소개합니다.

어릴 적 오락실에서 동전 쌓아놓고 즐기던 벽돌깨기(Breakout) 게임, 기억하시나요? 그 추억의 게임을 여러분의 익숙한 엑셀 프로그램 안에서 그대로 재현했습니다! 설치 NO! 복잡한 설정 NO! 그저 VBA 코드만 붙여넣으면 여러분의 엑셀이 바로 게임장이 됩니다!

️ 간단한 게임 방법 & 조작키 (30초 만에 게임 마스터!)

엑셀 벽돌깨기 게임은 남녀노소 누구나 쉽게 즐길 수 있습니다. 복잡한 컨트롤러도, 외워야 할 스킬도 없습니다!

게임 시작!
- VBA 편집기(Alt + F11)를 열어 Module1의 StartBreakoutGame 서브루틴 안에 커서를 두고 F5 키를 누르세요.
- 또는 엑셀 화면에서 개발 도구 탭 > 매크로 > StartBreakoutGame을 선택하고 실행 버튼을 클릭하세요.
- 짜잔! 화면에 벽돌과 패들, 공이 나타나며 게임이 시작됩니다.
게임 조작키
- 좌우 방향키 (← →): 패들(아래 막대기)을 좌우로 움직여 공을 받아내세요.
- 스페이스바 (Spacebar): 게임이 일시 정지 상태일 때 (예: 생명을 잃었을 때) 스페이스바를 누르면 다시 공이 발사되며 게임이 재개됩니다.
- ESC 키: 게임을 즉시 종료하고 싶을 때 누르세요.
게임 목표
- 공을 패들로 튕겨 올려 화면 상단의 벽돌들을 모두 부수세요.
- 모든 벽돌을 부수면 다음 레벨로 진입하며, 공의 속도가 조금씩 빨라져 난이도가 올라갑니다.
- 공이 화면 하단으로 떨어지면 생명(Lives)을 잃게 됩니다. 주어진 생명(기본 3개)을 모두 잃으면 게임 오버!
- 가장 높은 레벨까지 도달하고, 최고 점수를 획득해 보세요!

Tip!

벽돌을 맞출 때마다 점수가 올라갑니다.
공이 패들의 중앙에 맞으면 정직하게 위로 튕겨 올라가고, 가장자리에 맞으면 더 큰 각도로 튕겨나가니 이를 활용하여 전략적으로 벽돌을 파괴해 보세요!
(선택 사항: 게임 플레이 중 Ctrl+Z 등을 눌러 실수로 실행 취소하는 것을 막기 위해 Ctrl+Z를 비활성화하는 VBA 코드를 추가할 수도 있습니다.)

Game_벽돌깨기_ver1.1.xlsm

엑셀 지뢰찾기: 숨겨진 스릴을 찾아라!

노만e — Tue, 22 Jul 2025 23:00:55 +0900

엑셀 지뢰찾기 사용법

당신만의 맞춤형 지뢰찾기 게임, 이제 엑셀에서 손쉽게 즐기세요! 이 매크로 기반 게임은 친숙한 엑셀 환경에서 지뢰찾기의 묘미를 그대로 선사합니다.

파일 열기: 게임이 포함된 .xlsm 파일을 엽니다. 자동으로 '게임' 시트가 나타나며, 상단에 게임 제목과 설정이 표시됩니다.
난이도 선택: J1 셀의 드롭다운 목록에서 원하는 **난이도(초급, 중급, 고급)**를 선택하세요. 난이도에 따라 게임판의 크기와 지뢰 수가 달라집니다.
게임 시작: K1:M1 셀에 있는 [시작] 버튼을 클릭합니다. 선택한 난이도에 맞춰 게임판이 2행부터 자동으로 생성됩니다.
셀 열기 (더블클릭): 지뢰가 숨어있지 않을 것 같은 셀을 더블클릭하여 여세요.
- 주변에 지뢰가 없으면 빈 공간이 자동으로 확장됩니다.
- 주변에 지뢰가 있다면, 그 개수(1~8)가 숫자로 표시됩니다.
- 지뢰를 밟으면 게임 오버! 모든 지뢰가 드러나며 게임이 종료됩니다.
깃발 표시 (마우스 우클릭): 지뢰가 있다고 확신하는 셀에는 마우스 우클릭으로 깃발( )을 꽂아 표시하세요. 다시 우클릭하면 깃발이 사라집니다. 깃발이 꽂힌 셀은 더블클릭으로 열리지 않습니다.
게임 승리: 모든 지뢰를 피하고 안전한 셀을 전부 열면 게임 승리! 축하 메시지가 나타납니다.
다시 시작: 게임이 끝나면 언제든지 [시작] 버튼을 다시 클릭하여 새로운 게임을 즐길 수 있습니다. 게임판은 자동으로 초기화됩니다.

지뢰찾기.xlsm

엑셀 VBA로 스도쿠 게임 만들기 – 난이도 선택과 힌트 기능까지 완벽 구현!

노만e — Mon, 21 Jul 2025 19:34:48 +0900

스도쿠 게임

엑셀 VBA로 스도쿠 게임을 직접 만들어보세요! 난이도 설정, 힌트 제공, 정답 확인 기능까지 갖춘 완성형 스도쿠 게임 코드를 소개합니다. VBA 학습과 실습을 한 번에!

본문 예시 (구조 포함)

들어가며: 엑셀로 스도쿠? 가능합니다!

엑셀에서 단순한 계산이나 표 작업만 한다고요? 아닙니다! 오늘은 엑셀 VBA로 만드는 스도쿠 게임을 소개합니다. 난이도 설정부터 힌트 제공, 정답 확인까지 전부 포함된 프로젝트예요. 실습을 통해 VBA 실력을 확 키워보세요!

준비 단계: VBA 편집기 열기

Excel 실행 후 [개발자] 탭 > [Visual Basic] 클릭

[삽입] > [모듈] 선택 후, 전체 코드를 붙여넣기

StartSudoku 매크로를 실행하면 게임판이 생성됩니다.

주요 기능 안내

① 스도쿠 판 생성 (SetupSudokuGame)

엑셀 시트에 9x9 스도쿠 셀 그리드 생성

3x3 구간마다 두꺼운 테두리로 구분

난이도 선택 콤보박스, 새 게임/힌트/정답 확인 버튼 추가

② 난이도 선택 + 게임 시작 (NewGame)

초급(35칸 비움), 중급(45칸), 고급(55칸) 설정 가능

백트래킹 알고리즘으로 해답 자동 생성

③ 힌트 제공 (ShowHint)

빈 칸을 선택 후 클릭하면 정답을 보여줌

노란색으로 표시되어 구분 쉬움

④ 정답 확인 (CheckSolution)

전체 칸이 채워졌는지 확인

정답과 일치 여부 판단 후 결과 메시지 출력

스도쿠 게임.xlsm