본문
안녕하세요!
오늘은 제가 직접 개발한 엑셀 VBA 애드인을 소개합니다.
이 애드인은 여러 개의 기준 셀을 선택하고, 동일한 헤드명 열에 값을 자동으로 대체할 수 있는 기능을 제공합니다.
특히 병합 셀 처리, 빈 셀 자동 건너뛰기, 값 대체 시 색상 표시까지 지원하여 엑셀 자료 정리에 최적화되어 있습니다.
🔹 주요 기능
- 다중 기준 셀 선택 가능
- 여러 셀을 선택해도 자동으로 값 있는 셀만 처리
- 동일 헤드명 열 자동 탐색
- 헤드명이 일치하는 열을 찾아 기준 값을 한 번에 복사
- 병합셀 처리
- 병합 셀을 포함한 기준 값도 정확히 대체
- 값 대체 시 색상 표시
- 변경된 셀은 노란색으로 표시되어 한눈에 확인 가능
- 엑셀 리본 버튼 연동
- 클릭 한 번으로 간편 실행
🔹 사용법
- 애드인을 설치 후, 리본 메뉴에서 버튼 클릭
- 기준이 될 셀을 선택 (다중 선택 가능)
- 비교할 헤드 영역을 선택
- 선택한 기준 값이 동일 헤드명 열에 자동으로 대체되고, 노란색으로 표시
🔹 활용 예시
- 월별 매출/재고 자료 정리
- 설문조사/데이터 수집 후 항목 통일
- 복잡한 보고서 자동화
🔹 설치 & 사용 팁
- 애드인은 엑셀 VBA 프로젝트로 구성되어 있으며, .xlam 파일로 배포 가능합니다.
- 설치 후 리본 메뉴에 버튼이 자동 생성됩니다.
- 다중 선택 시 빈 셀은 자동 건너뛰므로, 자료 정리 시간을 크게 단축할 수 있습니다.
- code
- Option Explicit
' 리본 버튼용
Public Sub 기준열_항목명기준_동일행대체(control As IRibbonControl)
Call 기준열동일셀대체
End Sub
Sub 기준열동일셀대체()
Dim ws As Worksheet
Dim headerRange As Range
Dim baseCell As Range
Dim selCell As Range
Dim nonEmptyCells As Range
Dim baseRow As Long, baseColNum As Long
Dim baseValue As String
Dim lastCol As Long
Dim r As Long, j As Long
Dim txtBase As String, txtTarget As String
Dim dictCols As Object
Dim cellVal As Variant
Dim found As Boolean
Dim key As Variant
Set ws = ActiveSheet
'---------------------------------
' 1. 기준 셀 선택 (다중 선택 가능)
'---------------------------------
On Error Resume Next
Set baseCell = Application.InputBox( _
"기준 셀을 선택하세요. (여러 셀 가능)", _
"기준 셀 선택", _
Type:=8 _
)
On Error GoTo 0
If baseCell Is Nothing Then Exit Sub
'---------------------------------
' 2. 값 있는 셀만 필터링
'---------------------------------
For Each selCell In baseCell.Cells
If Trim(CStr(selCell.Value)) <> "" Then
If nonEmptyCells Is Nothing Then
Set nonEmptyCells = selCell
Else
Set nonEmptyCells = Union(nonEmptyCells, selCell)
End If
End If
Next selCell
If nonEmptyCells Is Nothing Then
MsgBox "선택 영역에 값이 있는 셀이 없습니다.", vbExclamation
Exit Sub
End If
'---------------------------------
' 3. 헤드 범위 선택
'---------------------------------
Set headerRange = Application.InputBox( _
"비교할 헤드 영역을 선택하세요 (예: A1:Z3)", _
"헤드 범위 선택", _
Type:=8 _
)
If headerRange Is Nothing Then Exit Sub
lastCol = ws.Cells(headerRange.Row, ws.Columns.Count).End(xlToLeft).Column
'---------------------------------
' 4. 기준 셀 각각 처리
'---------------------------------
For Each selCell In nonEmptyCells
baseRow = selCell.Row
baseColNum = selCell.Column
' 기준값 가져오기 (병합셀 처리)
If selCell.MergeCells Then
baseValue = selCell.MergeArea.Cells(1, 1).Value
Else
baseValue = selCell.Value
End If
baseValue = Trim(CStr(baseValue))
If baseValue = "" Then GoTo NextCell
'---------------------------------
' 4-1. 기준 열의 헤드명 찾기
'---------------------------------
found = False
For r = 1 To headerRange.Rows.Count
cellVal = ws.Cells(headerRange.Row + r - 1, baseColNum).Value
If ws.Cells(headerRange.Row + r - 1, baseColNum).MergeCells Then
cellVal = ws.Cells(headerRange.Row + r - 1, baseColNum).MergeArea.Cells(1, 1).Value
End If
If Trim(CStr(cellVal)) <> "" Then
txtBase = UCase(Replace(Replace(Trim(CStr(cellVal)), Chr(160), ""), vbLf, ""))
found = True
Exit For
End If
Next r
If Not found Then GoTo NextCell
'---------------------------------
' 4-2. 동일 헤드명 열 찾기
'---------------------------------
Set dictCols = CreateObject("Scripting.Dictionary")
For j = 1 To lastCol
If j <> baseColNum Then
For r = 1 To headerRange.Rows.Count
cellVal = ws.Cells(headerRange.Row + r - 1, j).Value
If ws.Cells(headerRange.Row + r - 1, j).MergeCells Then
cellVal = ws.Cells(headerRange.Row + r - 1, j).MergeArea.Cells(1, 1).Value
End If
txtTarget = UCase(Replace(Replace(Trim(CStr(cellVal)), Chr(160), ""), vbLf, ""))
If txtTarget = txtBase Then
dictCols(j) = True
Exit For
End If
Next r
End If
Next j
'---------------------------------
' 4-3. 동일 행 값 대체 + 색상 표시
'---------------------------------
For Each key In dictCols.Keys
ws.Cells(baseRow, key).Value = baseValue
ws.Cells(baseRow, key).Interior.Color = RGB(255, 255, 0)
Next key
NextCell:
Next selCell
MsgBox "완료!", vbInformation
End Sub