'업무 능력 향상'에 해당되는 글 240건

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

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

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

Pivot 을 엑셀에서 일일이 매번 지정하려니까 너무 귀찮아서 피벗 VBA 를 아예 만들었다.

어떻게 만드는지 감이 오지 않으면 매크로를 실행해서 만들어진 코드를 분석하면 쉽게 이해할 수 있다.

Sub pivot_make()
    Dim endRow As Long
    Dim CurrentPosition
    Dim C As Range
    Dim rngAll As Range
    Dim wSheet As Worksheet
    Dim wkSht As Worksheet

    On Error Resume Next
    Set wkSht = ThisWorkbook.Worksheets("B_Sheet")
    If Err.Number = 0 Then
        ' Application.DisplayAlerts = False
        ' Worksheets("B_Sheet").Delete
        ' Application.DisplayAlerts = True
    Else
    Worksheets("A_Sheet").Activate
    Worksheets("A_Sheet").Copy after:=Worksheets("A_Sheet")
    ActiveSheet.Name = "B_Sheet"
    End If

    Sheets("B_Sheet").Select
    endRow = Cells(Rows.Count, "A").End(3).Row '// 셀의 마지막 위치가 계속 변하므로

    Cells(1, 1).Select
    If Cells(3, 1) <> "등록일" Then
        Selection.EntireRow.Insert
        Selection.EntireRow.Insert
    End If
    Cells(3, 1).Select
    ActiveSheet.AutoFilterMode = False
    If ActiveSheet.AutoFilterMode = False Then
        Selection.AutoFilter
    End If
    Cells(3, "C").Select

    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(3, "C").Select

    '###### 분류 작업 #######
    Set rngAll = Range([C3], Cells(Rows.Count, "C").End(3))

    Application.ScreenUpdating = False
    rngAll.Replace "회사", vbNullString
    rngAll.Offset(0, 1).Replace "기술부", vbNullString

    '##### 피벗테이블 생성 #####
    Sheets("B_Sheet").Select

    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Pivot_New").Delete '// 기존 피벗테이블 삭제
    Sheets.Add(after:=Sheets(8)).Name = "Pivot_New" '새로운 피벗시트를 생성

    Set rngData = Sheets("B_Sheet").Range("A3").CurrentRegion
    Set rngB = ActiveWorkbook.Worksheets("Pivot_New").Range("A3")

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData, _
    Version:=xlPivotTableVersion14).CreatePivotTable TableDestination:=rngB, _
    TableName:="PVR", DefaultVersion:=xlPivotTableVersion14

    '// 보고서 필터
    With ActiveSheet.PivotTables("PVR").PivotFields("부서")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PVR").PivotFields("지역")
        .Orientation = xlPageField
        .Position = 2
    End With

    '// X축
    With ActiveSheet.PivotTables("PVR").PivotFields("분류")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PVR").PivotFields("고객")
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables("PVR").PivotFields("분류").LayoutForm = xlTabular
    ActiveSheet.PivotTables("PVR").PivotFields("고객").LayoutForm = xlTabular

    '// Y축
    With ActiveSheet.PivotTables("PVR").PivotFields("팀")
        .Orientation = xlColumnField
        .Position = 1
    End With

    '// 화면에 표시될 값(결과)
    ActiveSheet.PivotTables("PVR").AddDataField ActiveSheet.PivotTables( _
    "PVR").PivotFields("고객수"), "합계 : 고객수", xlSum

    '// 화면에서 보이지 않게 처리
    ActiveSheet.PivotTables("PVR").PivotFields("지역").CurrentPage = "(All)"
    With ActiveSheet.PivotTables("PVR").PivotFields("지역")
        .PivotItems("서울").Visible = False
        .PivotItems("대구").Visible = False
        .PivotItems("부산").Visible = False
        .PivotItems("전남").Visible = False
        .PivotItems("전북").Visible = False
        .PivotItems("충남").Visible = False
        .PivotItems("충북").Visible = False
        .PivotItems("제주").Visible = False
        .PivotItems("강원").Visible = False
    End With

    ActiveSheet.PivotTables("PVR").PivotFields("담당").EnableMultiplePageItems = True

    MsgBox "피벗 생성완료"
End Sub

    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

Httprequest Header 정보를 만들기 위해 작성한 코드이다.

불필요한 헤더 정보도 있지만 그건 작성하면서 수정하면 된다.

Sub httprequest_header()
    Dim rngC As Range
    Dim rngAll As Range
    Dim tmp As Integer
   
    Application.ScreenUpdating = False
    Set rngAll = Range([C3], [C3].End(4))
   
    For Each rngC In rngAll
        tmp = InStr(rngC, ":")
        If tmp > 0 Then
            If Left(rngC, tmp - 1) = "User-Agent" Then
                rngC.Offset(0, -2) = "request.UserAgent" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Accept-Language" Then
                rngC.Offset(0, -2) = "request.AcceptLanguage" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Accept-Encoding" Then
                rngC.Offset(0, -2) = "request.AcceptEncoding" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Content-Type" Then
                rngC.Offset(0, -2) = "request.ContentType" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Content-Length" Then
                rngC.Offset(0, -2) = "request.ContentLength=sendData.Length;"
            ElseIf InStr(rngC, "keep-alive") > 0 Then
                rngC.Offset(0, -2) = "request.KeepAlive=true;"
            Else
                rngC.Offset(0, -2) = "request." & Left(rngC, tmp - 1) & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            End If
        Else
            rngC.Offset(0, -2) = rngC
        End If
    Next rngC
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

자막 정리를 좀 하다보니 바로 위아래 셀 병합을 해야 하는 경우와

한글과 영문이 쌍으로 되어 있어서 한행 아래것과 셀병합을 해야 하는 경우가 있다.

현재 행과 아래행을 병합할 때

Sub Cell_Merge()    '// 위아래 셀 병합
    Dim r&, h&, C As Range
    Set C = Selection
    If C.Count < 2 Then Exit Sub
    If C.Columns.Count > 1 Then MsgBox "열은 합칠 수 없습니다.", 16, "규정위반": Exit Sub
    
    With Selection
        h = .Rows.Count - 1
        For r = 1 To h Step 1
             .Cells(1) = .Cells(1) & " " & .Cells(r + 1)
        Next
        .Cells(2).Resize(h).Delete Shift:=xlUp
    End With
    ActiveCell.Select
End Sub

현재 행과 한칸 아래 행을 병합할 때

Sub subtitle_merge()    '// 한칸 아래셀과 병합
    Dim r&, h&
    With Selection.Resize(, 1)
        If .Rows.Count Mod 2 = 0 Then
            h = .Rows.Count - 2
            If h < 1 Then MsgBox "최소 4개행을 선택해야 합니다", 16, "규정위반": Exit Sub
            For r = 1 To h Step 2
                .Cells(1) = .Cells(1) & " " & .Cells(r + 2)
                .Cells(2) = .Cells(2) & " " & .Cells(r + 3)
            Next
            .Cells(3).Resize(h).Delete Shift:=xlUp
        Else
            MsgBox "홀수행 선택은 안됩니다", 16, "규정위반": Exit Sub
        End If
    End With
    ActiveCell.Select
End Sub

자막에서 두사람의 대화인 경우 대쉬(-)를 넣어서 구분되어 있다.

-But if you just... -Rapunzel, we're done talking about this.
-그렇지만 만약… -라푼젤, 이제 이 이야긴 그만하자
-Trust me,... -Rapunzel.
-믿어주세요 전… -라푼젤
-...I know what I'm -Rapunzel.
-알아요 전… -라푼젤
-Oh, come on. -Enough with the lights, Rapunzel.
-제발요 엄마 -너에게 다른 인생이란 없어 라푼젤

이런 자막인 경우에 VBA 를 이용하여 분리 저장을 해봤다.

내가 잘 몰라서 그런지 몰라도 위에서 부터 아래로 For 문을 돌리면 끝까지 처리가 안된다.

그래서 맨 아래줄부터 위로 처리하는 로직으로 구현을 하고 테스트를 해봤다.

자막에 - 가 들어가 있는데 1개만 들어간 경우가 있다. 이 경우에는 - 를 제거해주고

- 가 두개 들어간 경우에는 개수를 먼저 표시한 다음에

자막 대사를 분리 저장하는 로직으로 구현했다.

Sub dash_check()    '// 대쉬가 들어간 것만 표시
    Dim r&, sRow&, eRow&, k&, j&, v
    Application.ScreenUpdating = False
    sRow = 2
    eRow = Cells(Rows.Count, "A").End(3).Row
    For r = sRow To eRow Step 1
        On Error Resume Next
        If InStr(Cells(r, 1), "-") Then     '// 셀에 대쉬(-)가 포함되어 있으면
            v = Split(Cells(r, 1), "-")     '// Split 함수를 이용하여 배열로 저장
            If UBound(v) = 1 Then       '// 배열의 개수를 파악하여 1개, 즉 대쉬(-)가 1개만 들어간 경우이면
                If Left(Cells(r, 1), 1) = "-" Then  '// 셀의 첫번째가 대쉬(-) 이면
                    Cells(r, 1) = Trim(Mid(Cells(r, 1), 2, Len(Cells(r, 1))))   '// 두번째 이후의 값을 다시 셀에 저장하라
                End If
            Else
                Cells(r, "D") = UBound(v)
                j = j + 1
            End If
        Else
            Cells(r, "D") = vbNullString
        End If
    Next r
    MsgBox "총 " & k + j & "개 표시  " & j & "개 " & k & "개"
End Sub

Sub subtitle_cellsplit()
'// 대쉬(-)가 2개 들어간 자막을 분리하여 저장 처리
'// 대쉬(-)가 들어간 자막은 아래부터 위로 처리를 해야 제대로 저장됨
    Dim r&, sRow&, eRow&, k&, j&, v, ss
    Application.ScreenUpdating = False
    sRow = 2
    eRow = Cells(Rows.Count, "A").End(3).Row
    For r = eRow To sRow Step -1
        If Cells(r, 4) = 2 And InStr(Cells(r, 1), "-") And Cells(r - 1, 4) = 2 And InStr(Cells(r - 1, 1), "-") Then
            ss = Split(Cells(r - 1, 1), "-")
            v = Split(Cells(r, 1), "-")
            Cells(r - 1, 1).Value = Trim(ss(1))
            Cells(r - 1, 1).Offset(2).EntireRow.Insert
            Cells(r - 1, 1).Offset(2).Value = Trim(ss(2))
            Cells(r, 1).Value = Trim(v(1))
            Cells(r, 1).Offset(2).EntireRow.Insert
            Cells(r, 1).Offset(2).Value = Trim(v(2))
            r = r - 1
        End If
            k = k + 1
    Next r
    MsgBox "총 " & k & "번 반복"
End Sub

자막을 정리할 때 필요한 코드.

Option Explicit
Sub Subtitle_delete()
    If Selection.Count > 1 Then
'        Debug.Print Selection.Count
        Selection.Delete Shift:=xlUp
    Else
        If MsgBox("1개의 셀인데 삭제하겠습니까?", vbYesNo) = vbYes Then
            Selection.Delete Shift:=xlUp
        End If
    End If
End Sub

Sub Subtitle_merge()
    Dim r As Long, h As Long
    With Selection.Resize(, 1)
        h = .Rows.Count - 2
        Debug.Print h
        If h < 1 Then Exit Sub
        For r = 1 To h Step 2
            .Cells(1) = .Cells(1) & " " & .Cells(r + 2)
            .Cells(2) = .Cells(2) & " " & .Cells(r + 3)
        Next
        .Cells(3).Resize(h).Delete Shift:=xlUp
    End With
End Sub

Sub Subtitle_Split()
    Dim rngC As Range, r As Long, c As Long, S As String, v
   
    Columns("A:B").NumberFormat = "@"      '// A:B열을 텍스트 서식으로
    If Cells(Rows.Count, 1).End(3).Row > 1 Then
        Range("b1:b" & Cells(Rows.Count, "B").End(3).Row).Offset(1).ClearContents
    Else
        MsgBox "정리할 자막이 없습니다" & vbCr & "자막부터 복사하세요"
        Exit Sub
    End If
    r = 1
    For Each rngC In Range("a2:a" & Cells(Rows.Count, 1).End(3).Row)
'        Debug.Print "현재 행 = " & rngC.Row
        If Left$(rngC, 2) = "- " And InStrRev(rngC, "- ") > 1 Then
            r = r + 1
            v = Split(rngC, "- ")
            On Error Resume Next
            Cells(r, 2) = v(1)
            S = S & vbLf & v(2)
'            Debug.Print "s 값 : " & s
        Else
            If S <> "" Then SplitTextAddLine r, S
            r = r + 1
            Cells(r, 2) = rngC
        End If
    Next rngC
  
    If S <> "" Then SplitTextAddLine r, S
   
    MsgBox "A열에서 복사 완료"
End Sub

Sub SplitTextAddLine(r, S)
    Dim v, c As Long
    v = Split(S, vbLf)
    For c = 1 To UBound(v)
        r = r + 1
        Cells(r, 2) = v(c)
    Next
    S = ""
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

같은 셀에서 줄바꿈(vbLf) 되어 있는 셀내에서 중복이 발생한 것은 제거를 하는 VBA 코드다.

Sub RemoveDuplicate_InCell()
    Dim rngC As Range, Dat As Variant, X As New Collection
    Dim tmp As String, i&
    On Error Resume Next
    For Each rngC In Range([A2], Cells(Rows.Count, "A").End(3)).SpecialCells(2)
        Dat = Split(rngC, vbLf)
        Set X = Nothing
        For i = 0 To UBound(Dat)
            X.Add rngC.Value, CStr(Dat(i))    '// 중복된 데이터는 저장하지 마라
            If Err.Number <> 457 Then    '// 만일 에러가 발생하지 않았으면
                If i = 0 Then
                    tmp = Dat(i)
                Else
                    tmp = tmp & vbLf & Dat(i)
                End If
            End If
            Err.Clear
        Next i
        rngC.Offset(, 1) = tmp
        tmp = vbNullString      '// 셀이 변경될 때 임시변수 초기화
    Next rngC
End Sub

서버에 자료가 있는지 SQL 문 조회를 하여 가져온 결과를 화면에 뿌릴때 구현하는 로직이다.

핵심사항만 적어둔다. 나머지 사항은 다른 게시물을 참조하면 된다.

        If RS.EOF Then
            DoEvents
        Else
            RS.MoveFirst  '// Move to the first record
             For i = 1 To RS.RecordCount  '// recordset의  필드 개수만큼 반복
                For n = 1 To RS.Fields.Count
                    If RS.Fields(n - 1) > 0 Then Cells(C.Row, n + 3) = "중복"   '// 표시하고 싶은 열에 중복 표시
                Next n
                RS.MoveNext
            Next i
        End If
        RS.Close    '//Close connection again