'업무 능력 향상/엑셀 VBA 기초'에 해당되는 글 72건

번지를 기준으로 주소 데이터를 분리하는 VBA 코드이다.

지번 주소 뒷자리에 나오는 데이터에 숫자가 들어간 경우 구글 스프레드시트에서 엉뚱한 위도, 경도를 반환하더라.

그래서 정확하게 위도,경도를 추출하기 위해서 세부 주소 데이터를 배제하고 번지까지만 주소 데이터를 추출한 다음에 위도, 경도 데이터를 추출했다.

    Cells(3, 1).Select
    If ActiveSheet.AutoFilterMode = False Then
        Selection.AutoFilter  '// 상시 필터 적용 옵션
    End If

Sorting 처리 명령어

    ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("C3:C" & endRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

찾고자 하는 내용 검색

    ActiveCell.Select
    Cells.Find(What:="검색어", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(-1, 0).Range("A1").Select

설명 : ActiveCell 에서 "검색어" 를 입력하면 결과가 검색된다. 가령 찾고자 하는 게 "업무" 라고 한다면, 검색어 대신에 업무로 변경하면 된다.

ActiveCell.Offset(-1, 0).Range("A1").Select 의 의미는 ActiveCell 에서 Offset(-1,0) 즉 Offset(행,열) 만큼 이동하라는 의미이므로 -1 은 이전행, 0 열은 현재 셀에서 열의 이동은 없이 바로 위의 셀을 가리키게 된다.

엑셀 시트를 선택한 다음에 이름을 지정해서 복사하는 방법이다.

선택한 Sheet : 목록

복사할 Sheet : TEST

Sub Add_Sheet()
    Sheets("목록").Select
    ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "TEST"
    
End Sub

시트가 있는지 검사한 다음에 없으면 복사하기

Sub Add_Sheet()
    Dim i As Integer
    Dim exists As Boolean
   
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "TEST" Then
            exists = True
        End If
    Next i
   
    If Not exists Then
        Sheets("목록").Select
        ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Name = "TEST"
    Else
        MsgBox "시트가 이미 존재합니다"
    End If
    
End Sub

VBA 다중정렬 코드를 찾아보니 3개까지만 키를 지원한다고 되어 있다.

그래서 일단 엑셀이 기본제공하는 다중정렬을 이용하여 정렬을 했는데 매번 찾으려니까 너무 귀찮다.

엑셀 매크로를 이용하여 코드를 기본 생성한 다음에 아래와 같이 수정했다.

E4 는 헤더열 바로 아래 셀이다.

총 4개의 열을 순서대로 정렬하기 위해 사용했다.

매크로로 만들면 실제 Sheet 명이 나오는데 전부 ActiveSheet 로 변경했다.

Sub 부서정렬()
    Dim endRow As Long
    Dim CurrentPostion

    endRow = Cells(Rows.Count, "A").End(3).Row  '// 셀을 추가하면 마지막 행의 위치가 계속 변함

    CurrentPostion = ActiveCell.Address    '// 현재 커서가 있는 셀을 변수에 담는다.
   
    ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("E4:E" & endRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("F4:F" & endRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("G4:G" & endRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("H4:H" & endRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Range(CurrentPostion).Select
End Sub

VBA 서식을 복사해서 한번에 처리해야 할 경우의 코드이다.

Sub Replace()
    Dim C As Range
    Dim rng As Range
   
    Set rng = Selection
   
    For Each C In rng
        C.Replace " ", "", xlPart
        If InStr(C, "팀") = 0 Then
            C = C & "팀"
        End If
       
        rng.Offset(-1, 0).Copy
        rng.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False

    Next C 
   
End Sub

시스템에서 엑셀로 받은 자료를 가지고 작업을 하다보니 한줄로 표시되어야 하는데 두줄로 표시가 되는 것이 있다.

에러의 원인이 되어 원하는 결과가 나오지 않는다.

그래서 VBA 코드를 만들어서 해결했다.

Sub 셀내줄바꿈해제()
    Dim rngC As Range
    Dim rngAll As Range
    Dim endRow As Long
  
    Application.ScreenUpdating = False
    endRow = Cells(Rows.Count, "A").End(3).Row
    If endRow < 4 Then
        endRow = 4
    End If
   
    Set rngAll = Range([H4], Cells(endRow, "H"))
  
    For Each rngC In rngAll
        If InStr(rngC, Chr(10)) Then
            rngC.Interior.ColorIndex = 6
            rngC = Replace(rngC, Chr(10), "")
        End If
    Next rngC
  
    MsgBox "완료"
End Sub

Sub 중복데이터제거()
    Range("A1:D" & Cells(Rows.Count, "A").End(3).Row).RemoveDuplicates Columns:=Array(3, 4), Header:=xlYes
End Sub

Sub 직위중복제거()
    Range("A1:B" & Cells(Rows.Count, "A").End(3).Row).RemoveDuplicates Columns:=Array(2), Header:=xlYes
End Sub

Sub name_delete()
    Dim r As Long, d As Long, k As Long, LastRow As Long
   
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, "A").End(3).Row
       
    For r = LastRow To 6 Step -1
        If Cells(r, "A") = "이름" And Cells(r, "B") = "부서명" Then
            Rows(r).EntireRow.Delete
            k = k + 1
        ElseIf IsEmpty(Cells(r, "A")) And IsEmpty(Cells(r, "B")) Then
            Rows(r).EntireRow.Delete
            d = d + 1
        End If
    Next r
   
    MsgBox k & "행 이름삭제 " & d & "빈행 삭제완료"
End Sub

특정 글자색이 포함된 셀이 아닌 행은 전부 삭제하는 VBA 코드다.

Sub StringColor_delete()
    Dim r As Double
    Dim LastRow As Double  '// 마지막 행의 변수
   
    Application.ScreenUpdating = False
    Debug.Print Cells(7, 1).Font.ColorIndex  '// 글자색 알아내기   
    LastRow = Cells(Rows.Count, "A").End(3).Row
   
    For r = LastRow To 1 Step -1   '// 삭제는 마지막행부터 역순으로
        If Cells(r, "A").Font.ColorIndex <> 50 Then  '// 알아낸 색상과 다른 셀이면
            Cells(r, "A").EntireRow.Delete  '// 그 셀이 포함된 행을 전부 삭제해라.
        End If
    Next r
  
End Sub

빈줄일 때 행의 높이를 적게 하기 위한 코드이다.

Sub blnksell_height()
    Dim rngC, rngAll As Range
   
    Application.ScreenUpdating = False
    Set rngAll = Range([B3], Cells(Rows.Count, "A").End(3))
   
    For Each rngC In rngAll
        If rngC = "" Then
            rngC.RowHeight = 10
        Else
            rngC.RowHeight = 22
        End If
    Next rngC
   
End Sub

엑셀 VBA 코드를 만드는 것은 이제는 좀 할 줄 안다.

그런데 VBA 코드 단축키를 어떻게 만드는지를 몰라 검색을 해봤는데도 잘 모르겠더라.

계속 Alt + F11 키를 누르면 나오는 화면에서 찾으니까 안나온다.

그런데 알고 보니까

그냥 엑셀 화면에서 Alt + F8 키를 누르니까 단축키 선택하는 옵션이 나온다.

Alt + 단축키 로 사용할 수 있는 것은 그림에서 보다시피 안된다.

Alt 키는 예약어로 되어 있는게 많은지 별로 동작하는게 없지만 가능한 방법은

로 하면 단축키를 누르면 사용자가 만든 VBA 코드가 동작한다.

아무래도 Alt + F8 눌러서 동작하는 걸 이용하는게 편하다는 걸 알 수 있다.

작업을 하다보면 행단위로 내용 파악을 쉽게 하고 싶은 경우가 생긴다.

아래 코드를 입력하면 셀에서 커서가 움직이는 행단위로 배경색이 보인다.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Cells.Interior.Color = xlNone
If Target.Count = 1 Then
     Range(Cells(ActiveCell.Row, "A"), Cells(ActiveCell.Row, "I")).Interior.Color = RGB(230, 230, 240)
 End If
End Sub

작업을 하다보면 색깔을 칠하면서 작업을 하게 된다. 그런데 마지막 색깔을 표시한 셀이 어디인지 찾기가 쉽지 않을 경우에 색상으로 마지막 셀을 찾는 방법이다.

배경색을 모를 경우 Msgbox Cells(2, 1).Interior.ColorIndex 를 하면 A2 셀의 배경색을 알아낼 수가 있다.

Sub last_colorcell_find()
    Dim r&, sRow&, eRow&
   
    sRow = 2
    eRow = Cells(Rows.Count, "A").End(3).Row
    Debug.Print Cells(2, 1).Interior.ColorIndex '// A2 셀의 배경색 알아내기
    For r = eRow To sRow Step -1
        If Cells(r, 1).Interior.ColorIndex = 14 Then   '// 녹색이면
            Cells(r, 1).Select
            Exit For
        End If
    Next r
End Sub

자동매크로 기능을 이용해서 얻어낸 텍스트 줄 바꿈 코드다.

Sub 텍스트줄바꿈()
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .MergeCells = False
    End With
End Sub

Sub 텍스트줄바꿈()
    With Range([D2], Cells(Rows.Count, "F").End(3))
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .MergeCells = False
    End With
End Sub

영어 검색어인 경우에는 asterisk 가 들어간 검색어가 될 수도 있다.

DB에 SQL 로 접속할 경우, 관련 자료가 하나도 없다고 결과를 돌려줄 수도 있다.

이럴 경우에는

    Keyword = Application.InputBox("검색 키워드를 입력하세요", "검색어", Type:=2)
    If InStr(Keyword, "'") > 0 Then    '// 영어 검색어에는 asterisk 가 포함되어 있을 수 있으므로
        Keyword = Replace(Keyword, "'", "\'")
    End If

와 같이 처리해주면 된다.

VBA 를 배우는 초보 입장에서 어려운 점은 원하는 걸 구현하기 위해서 어떤 IF 조건문을 쉽게 찾아내거나 알아서 로직을 구현할 것인가 하는 점이다.

아래 IF 조건문은 그동안 VBA 를 배우면서 익힌 것들인데 앞으로도 계속 추가를 할 생각이다.

IF 조건문 사용함수만 잘 알아도 코딩 시간이 훨씬 줄어든다.

If IsEmpty(rngC) Then        '// 선택된 셀이 비어있다면

If Not IsEmpty(rngC) Then  '// 각 셀이 빈셀이 아니라면

If InStr(rngC, "http") Then   '// http 가 포함되어 있다면, 즉, 웹주소라면

If WorksheetFunction.CountIf(rngC, "*" & FindText & "*") = 0 Then  '// 찾고자 하는 글자가 있다면

If TypeName(fileNames) = "Boolean" Then Exit Sub    '// 취소 선택 시 매크로 종료

If rngC Like "*[가-힣]*" Then   '// 셀에 한글이 포함되어 있으면

If strName = "False" Then         '//취소(Cancel) 선택 시
    MsgBox "취소(Cancel)하여 중단합니다.", 64, "파일선택 오류"  '//오류메시지 출력
    Exit Sub                             '// 매크로 중단
End If

If (iCol = 1) Or (iCol = 6) Or (iCol = 7) Then  '// 지정된 열일 경우

Counter = InputBox("분할할 행의 수 입력하세요")
If Counter = vbNullString Then Exit Sub           '// 취소 선택시 매크로 중단

If Not IsNumeric(Counter) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우 매크로 중단

If Not IsEmpty(rngC.Value) And IsNumeric(rngC.Value) Then  '// 빈셀이 아니고 숫자이면

If MsgBox("기존 데이터를 지울까요?", vbYesNo, Caption) = vbYes Then Sheets("SEARCH_DATA").Cells.Offset(1).Clear

fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls", , _
"엑셀 파일을 선택", MultiSelect:=False)   '// 엑셀 파일을 선택
If fileName = "False" Then Exit Sub       '// 취소 선택시 매크로 종료

If Len(rgnC) - Len(Replace(rgnC.Value, "-", "")) = 3 Then

    rgnC.Offset(0, 1) = Left(rngC, InStrRev(rngC, "-") - 1)

Else

    rngC.Offset(0, 1) = r

End If

Sub 셀에넣기()
    Cells(Rows.Count, "C").End(3)(2) = Application.Caller
End Sub

위와 같이 클릭시 아래로 문구들이 붙는 버튼을 만들었습니다.

여기서 변형으로

중간에 삭제시 빈 공간이 생겼을때

빈공간부터 채워지고 빈공간이 없을때

맨 아래로 이어서 채워지게 할 수는 없을까요?

End(4) 는 위로부터 셀이 아래로 내려가면서 공백이 나오기 바로 전 셀입니다.
End(xlDown).offset(1) = End(4)(2)는 같은 의미입니다.

Sub 셀에넣기()
    If Cells(2, "C").End(4)(2) = vbNullString Then   '// 셀이 비어있으면
        Cells(Rows.Count, "C").End(4)(2) = Application.Caller
    End If
End Sub

엑셀의 셀을 2칸씩 셀병합을 자동으로 하는 VBA 코드이다.

Sub CellMerge()
    Dim r As Long, eRow As Long, n As Long
   
    eRow = Cells(Rows.Count, "A").End(3).Row   '// A열의 마지막행
    Application.DisplayAlerts = False
    With Range("A2:B" & eRow)
        .UnMerge    '// 셀 병합 해제
        For r = 2 To eRow Step 2   '// 2씩 증가
            n = n + 1  '// 순번
            Cells(r, "a").Resize(2).Merge  '// A열 병합
            Cells(r, "a") = n  '// 순번
            Cells(r, "b").Resize(2).Merge   '// B열 병합
        Next
    End With
    Application.DisplayAlerts = True
End Sub

병합된 셀에서 원하는 데이터를 찾아서 가져오는 코드를 만들어봤다.

MergeArea_ex-01.xlsm

Sub Macro()
'// 엑셀에서 Alt + F11 키 누르면 뜨는 창에서 메뉴 [삽입] - [모듈] 선택
'// 이 코드를 붙여넣기
'// F5키를 누르면 실행됨
    Dim rngC As Range
    On Error Resume Next
    For Each rngC In Range([B2], Cells(Rows.Count, "B").End(3)) '// 구간 범위 설정

        If rngC.MergeCells And Not IsEmpty(rngC) Then
            Debug.Print "이름 : " & rngC.Text   '// 직접 실행창(Ctrl + G) 에서 출력되는 내용
            If rngC.Text = "순이" Then   '// 특정셀을 기록해야 하는데 직접 이름을 적어봤음
                MsgBox rngC.Offset(, 1).Offset(1)
            End If
        End If
    Next rngC
End Sub

'// 사용자가 만들어서 사용하는 함수
Function Find_Data(ByVal Name As String) As String
'// 엑셀에서 Alt + F11 키 누르면 뜨는 창에서 메뉴 [삽입] - [모듈] 선택
'// 이 코드를 붙여넣기
    Dim rngC As Range
    On Error Resume Next
    For Each rngC In Range([B2], Cells(Rows.Count, "B").End(3)) '// 구간 범위 설정
        '//B2셀부터 B열의 값이 있는 마지막 열까지
        If rngC.MergeCells And Not IsEmpty(rngC) Then
            Debug.Print "이름 : " & rngC.Text   '// 직접 실행창(Ctrl + G) 에서 출력되는 내용
            If rngC.Text = Name Then
                Find_Data = rngC.Offset(, 1).Offset(1)
            End If
        End If
    Next rngC
End Function
 

참조할 구간범위 및 몇번째 자료를 가져올 것인가를 정하는 것도 한번 작성해봤다.

Function Find_Lookup(ByVal Name As String, ByVal rngDB As Range, ByVal n As Integer) As String
'// 엑셀에서 Alt + F11 키 누르면 뜨는 창에서 메뉴 [삽입] - [모듈] 선택
'// 이 코드를 붙여넣기
    Dim rngC As Range
    On Error Resume Next
    For Each rngC In rngDB   '// 구간 범위 설정
        If rngC.MergeCells And Not IsEmpty(rngC) Then
            If rngC.Text = Name Then
                Find_Lookup = rngC.Offset(, n).Offset(1)
            End If
        End If
    Next rngC
End Function

* 첨부파일에 코드가 다 들어 있습니다.

파일을 읽어오면 파일경로와 파일명까지 표시를 해주는데 파일 경로(Path)만 알고 싶은 경우가 있다.

이럴 경우 파일 경로를 뿌려주는 코드이다.

상위코드까지 고려해서 작업을 해봤다. 붉은 글씨 숫자를 줄이면 더 상위경로명을 반환한다.

현재 폴더의 Path 만 알아내고 싶은 경우에는

Left(fileName, InStrRev(fileName, "\")) 로 하면 된다.

InStrRev 함수는 가장 오른쪽에 있는 위치의 값을 정수로 반환한다.

Sub getPath()
    Dim v
    Dim i%, n%
   
    v = Split(Cells(5, "E"), "\")
    ReDim Dat(1 To 1)
    For i = LBound(v) To UBound(v) - 1
        n = i + 1
        ReDim Preserve Dat(1 To n)
        Dat(n) = v(i)
    Next
    Cells(7, "E") = Join(Dat, "\")
End Sub

함수로 만들어서 사용하는 방법은

Function getPath(fileName$, Optional c% = 0)
    Dim v As Variant, i%, n%
    v = Split(fileName, "\")
    ReDim Dat(1 To 1)
    For i = LBound(v) To UBound(v) - 1 - c
        n = i + 1
        ReDim Preserve Dat(1 To n)
        Dat(n) = v(i)
    Next
    getPath = Join(Dat, "\")
End Function

반올림하여 %로 결과를 알고 싶어서 찾아보니 역시나 엑셀에서 기본 제공하는 Application.Round(수식,자리수)를 이용하면 쉽게 해결할 수 있다. 

VBA 로 복잡한 수식을 코딩할 필요가 전혀 없다.

메시지 팝업창 하나에 여러줄의 내용을 표시하고 싶은 것도 표기할 수 있는 걸 적어둔다.

Sub 개수파악()
    Dim rngC, rngAll As Range
    Dim Msg As String
   
    Application.ScreenUpdating = False  
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    Msg = "Move 수 = " & Application.CountIf(rngAll, "*원본") & vbNewLine
    Msg = Msg & "Total 수 = " & rngAll.Rows.Count & vbNewLine
    Msg = Msg & Application.Round(Application.CountIf(rngAll, "*원본") * 100 / rngAll.Rows.Count, 2) & "%"
    MsgBox Msg
End Sub