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

엑셀 VBA에서 가장 범하기 쉬운 오류가 Range 범위를 잡는 방법이다.

Range 를 많이 잡으면 메모리 공간을 많이 차지하므로 작업속도가 엄청나게 느려질 수 있다.

그래서 자료가 5만개, 10만개 30만개 60만개, 100만개나 되는 데이터 작업을 할 때에는 반드시 Range 범위를 분할해주어야 한다.

약 10만개의 전화번호 데이터를 작업하는데 내 PC 기준으로 100초 걸렸다.

코드를 최적화하는 방법을 고민하느라고 시간을 많이 할애하였다.

계속 고민하다보면 더 나은 방법은 계속 찾아지는 거 같다

이 코드는 아래 빨간색으로 된 부분만 수정해서 사용하면 됩니다.

컴퓨터 성능에 따라서 SplitLine 을 적정하게 변경하면 되구요. 시작할 행과 전화번호가 들어있는 열만 변경해주면 끝~~!!!!

만약 정리하고 싶은 전화번호가 전부 휴대폰번호라고 한다면 수정할 부분은

               Case 8      '//
                    rngC.Offset(0, 1) = "010-" & Format(strU, "0000-0000")

라고 수정해주면 됩니다.

첨부파일은 텍스트파일이므로 열어서

엑셀에서 Alt + F11 키를 누르고 내용을 붙여넣기를 하면 됩니다.

Optimize_TelNo.vbs

Option Explicit
Sub 부하없는전화번호정리()
    Dim strU As String      '// 문자를 합쳐갈 변수
    Dim rngC, rngDB As Range       '// 각 Line 변수
    Dim i, n, r As Double, rcnt%
    Dim SplitLine, sRow, eRow As Double
    Dim Col As String   
    Dim T As Single

    Application.ScreenUpdating = False    '// 화면 업데이트 (일시) 중지
    T = Timer()     '// 시간 변수 설정
    sRow = 2        '// 시작할 행
    Col = "E"       '// 전화번호가 들어있는 열 지정
    SplitLine = 3000    '// 전체행을 모두 범위설정하면 메모리 부족현상으로 속도저하 발생
    rcnt = ((Cells(Rows.Count, Col).End(3).Row - sRow) \ SplitLine) + 1

    For n = 1 To rcnt
        If (SplitLine + sRow) > Cells(Rows.Count, Col).End(3).Row Then
            eRow = Cells(Rows.Count, Col).End(3).Row     '// 마지막 행이 SplitLine 보다 작으면
        Else
            eRow = SplitLine + sRow                  '// 마지막 행이 SplitLine 보다 크면
        End If
       
        Set rngDB = Range(Cells(sRow, Col), Cells(eRow, Col))
        For Each rngC In rngDB
            r = rngC.Row
            For i = 1 To Len(rngC)                      '// 전체 문자길이 만큼 반복
                    If IsNumeric(Mid(rngC, i, 1)) Then  '// 문자열이 숫자일 경우
                        strU = strU & Mid(rngC, i, 1)   '// 각 숫자를 합쳐감
                    End If
            Next i

            Select Case Len(strU)     '// IF 문에서 숫자만 추출된 strU 의 길이 검사
                Case 8      '// 전국대표번호 처럼 8자리로 된 경우
                    rngC.Offset(0, 1) = Format(strU, "0000-0000")
                Case 9
                    rngC.Offset(0, 1) = Format(strU, "00-000-0000")
                Case 10
                    If Left(strU, 2) = "02" Then
                        rngC.Offset(0, 1) = Format(strU, "00-0000-0000")
                    Else
                        rngC.Offset(0, 1) = Format(strU, "000-000-0000")
                    End If
                Case 11
                    rngC.Offset(0, 1) = Format(strU, "000-0000-0000")
            End Select
            strU = ""   '// 값을 기록했으니까 초기화가 필요함
        Next rngC
        Set rngDB = Nothing   '// 메모리 비우기 (초기화)
        sRow = r + 1    '// 시작행으로 지정
    Next n
    MsgBox "완료!! " & vbLf & vbLf & Format(Timer() - T, "0.00초 걸림"), 64, Now()
End Sub

중간 중간의 셀이 빈 공백으로 되어 있는 경우 끝까지 번호를 매기려면 마우스로 Drag 하여 죽 끌고가거나 약간의 편법을 써야 하는 불편함이 있다.

이짓도 하다보니 좀 귀찮아서 간단하게 VBA 로

For Each Next 구문을 이용하여 만들었다.

rngC 는 반복하는 셀이고, rngC.Offset(0,2) 는 현재셀로부터 Offset(행,열) 즉, 행과 열만큼 이동하라는 의미다.

Offset(0,2) 는 행은 이동하지 말고, 열만 오른쪽으로 두번 이동하라는 의미이므로

rngC 셀이 A열에서 변동되므로 기록될 값은 C열에 기록된다.

Sub 번호매기기()
    Dim rngC As Range
    Dim i As Long
    For Each rngC In Range([A2], Cells(Rows.Count, "A").End(3))
        i = i + 1
        rngC.Offset(0, 2) = i
    Next rngC
End Sub

여기서 한가지 더 알아두면 좋은 사항은

rngC.Offset(0,2) 라는 것이 얼른 눈에 들어오지 않을 수도 있다.

이럴 경우에는 Cells(rngC.Row, "F") 와 같은 식으로 바꿔서 쓸수도 있다.

F열에 값을 기록한다는 것이므로 눈에 쉽게 들어온다.

하다보니 이것도 귀찮아서 더 편한 방법을 찾아서 적어둔다.

Sub 번호매기기()
    Dim rngC As Range
    Dim i As Long
    Dim sRow As Long
    Dim Col As String
   
    sRow = 2    '// 시작할 행
    Col = "A"   '// 지정할 열
    For Each rngC In Range(Cells(sRow, Col), Cells(Rows.Count, Col).End(3))
        i = i + 1
        Cells(rngC.Row, "O") = i
    Next rngC
End Sub

공백을 구분자로 주소를 분리하여 저장하는 VBA 코드이다.

Sub 주소변환()
    Dim rngC As Range
    Dim rngAll As Range
    Dim i, n As Long
    Dim v
    Dim strU As String
   
    Application.ScreenUpdating = False
    Set rngAll = Range([A3], Cells(Rows.Count, "A").End(3)) '// 원본 주소데이터 구간 범위 지정
    Range([B2], Cells(Rows.Count, "F").End(3)).Offset(1).ClearContents  '// 변환주소값 기록할 곳 초기화
    For Each rngC In rngAll     '// 원본구간내 셀을 순환 시작
        v = Split(rngC, " ")        '// 공백으로 문자를 분리
        n = UBound(v)             '// 분리된 배열의 갯수 파악
        rngC.Offset(0, 1) = v(0)    '// 배열 v(0) 를 B열에 저장
        rngC.Offset(0, 2) = v(1)    '// 배열 v(1) 를 C열에 저장
        rngC.Offset(0, 3) = v(2)    '// 배열 v(2) 를 D열에 저장
        If n = 3 Then
            strU = v(3)
            rngC.Offset(0, 5) = SplitText(strU)
        ElseIf n = 4 Then
            rngC.Offset(0, 4) = v(3)
            strU = v(4)
            rngC.Offset(0, 5) = SplitText(strU)
        End If
    Next rngC
    Set rngAll = Nothing    '// 메모리 비우기(초기화)
    MsgBox "주소 분리 완료"
End Sub

Function SplitText(ByRef r As String)
    Dim v
    v = Split(r, "-")
    If UBound(v) < 1 Then
        SplitText = Format(v(0), "0000") & "-" & "0000"
    Else
        SplitText = Format(v(0), "0000") & "-" & Format(v(1), "0000")
    End If
End Function

두개의 조건이 일치하는 데이터를 찾아서 중복이라고 표시해주는 VBA 코드이다.

전화번호와 이름이 일치하는 데이터만 중복이라고 표시를 한다.

다중조건 Find.xlsm

Sub 다중열조건Find()
    Dim sht1, sht2    As Worksheet   '// 시트(Sheet)를 넣을 변수   
    Dim Target As Range     '// 검사할 시트의 범위 구간
    Dim rngAll As Range, FindCell As Range  '// 현재시트의 구간 범위
    Dim C As Range, strAddr As String   '// 영역변수 및 주소를 저장할 변수
    Dim i As Long
   
    Application.StatusBar = True
    Set sht1 = Sheets("Main")   '// Main 워크시트는 현재 시트
    Set sht2 = Sheets("Data")   '// Data 워크시트는 데이터가 있는 Target 시트
    Set rngAll = sht1.Range(sht1.Cells(2, "B"), sht1.Cells(Rows.Count, "B").End(3))
    Set Target = sht2.Range(sht2.Cells(2, "B"), sht2.Cells(Rows.Count, "B").End(3))
   
    sht1.Select
    rngAll.Offset(0, 2).ClearContents   '// 결과 기록값 초기화
    rngAll.Offset(0, 3).ClearContents   '// 결과 기록값 초기화
   
    For Each FindCell In rngAll.Cells
        Application.StatusBar = "셀: " + FindCell.Address(0, 0) + " / " + FindCell + " 진행중..."
        Set C = Target.Find(what:=FindCell, Lookat:=xlWhole)
        '// Target 범위에서 FindCell 과 100% 일치하는 데이터를 찾아 C에 넣어라
        If Not C Is Nothing Then    '// 찾는 값이 있으면
            strAddr = C.Address     '// 최초 셀 주소를 기억하게 strAddr 에 저장
            Do  '// 무한 루프 시작
                If C.Offset(0, 1).Value = FindCell.Offset(0, 1).Value Then '// 옆의 셀이 서로 일치하면
                    i = i + 1
                    FindCell.Offset(0, 2) = "중복"    '// 현재 시트의 찾는셀 우측으로 2번째에 기록
                    If i > 1 Then
'                        FindCell.Offset(0, 2) = FindCell.Offset(0, 2) + vbNewLine + "중복"
                        FindCell.Offset(0, 3).Value = i   '// 같은 자료가 2개 이상이면 숫자를 기록
                    End If
                    Debug.Print "전화번호 : " & C.Offset(0, 1)
                End If
                Set C = Target.FindNext(C)   '// 다음셀을 찾음
            Loop While Not C Is Nothing And strAddr <> C.Address    '// 찾는 셀이 없거나 첫번째 셀이면 루프문 종료
            i = 0
        End If
    Next
    Application.StatusBar = "작업완료"

   Set rngAll = nothing    '// 메모리 비우기
End Sub

비교하려는 열의 값을 약간 확장해서 한다면 아래와 같이 수정해서 사용하면 된다.

    src_cell = 13   '// 비교하려는 열
    dst_cell = 13  '// 비교하려는 열

를 For 문 앞에 추가하고

            Do  '// 무한 루프 시작
                If C.Offset(0, dst_cell).Value = FindCell.Offset(0, src_cell).Value Then
                    FindCell.Offset(0, src_cell).Interior.ColorIndex = 28
                    C.Offset(0, dst_cell).Interior.ColorIndex = 28
                End If
                   
                FindCell.Interior.ColorIndex = 15    '// 회색으로 설정
                C.Interior.ColorIndex = 15
               
                Set C = Target.FindNext(C)   '// 다음셀을 찾음
            Loop While Not C Is Nothing And strAddr <> C.Address  '// 찾는 셀 없거나 첫번째 셀이면 루프문 종료

전화번호에 - 가 들어간 경우 이걸 제거하고 앞자리에 0이 같이 표기되도록 하고 싶은 경우에는 

Replace 함수를 사용하면 앞자리 0 이 지워진다. 엑셀에서 제공하는 substitute 함수를 이용하면 0이 지워지지 않고 남아있다.

엑셀 셀서식의 오류를 방지하기 위해서 A열 전체를 텍스트 서식으로 지정했다.

작업해야 할 데이터가 너무 많으면 For Each Next 문을 분할해서 처리하는 게 좋다.

범위구간을 너무 많이 잡으면 메모리를 많이 차지하여 원하는 작업을 하는데 속도저하가 심하게 일어난다.

http://link2me.tistory.com/617 보다 더 효율적으로 구간설정하는 법을 알게되면 업데이트 해두려고 한다.

구간을 설정하는 방법을

Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))

라고 할 수도 있지만,

Set rngAll = Range("A2:A" & Cells(Rows.Count, "A").End(3).Row) 라고 설정할 수도 있다.

Sub 전화번호대쉬제거()
    Dim rngC As Range    '// 각 셀을 넣을 변수
    Dim rngAll As Range      '// 선택영역 전체 범위 변수
   
    Range([A2], Cells(Rows.Count, "A")).NumberFormat = "@"   '// 텍스트 서식으로
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    On Error Resume Next
    rngAll.SpecialCells(xlCellTypeBlanks).EntireRow.Delete  '// 빈셀일 경우 해당 Row(행) 삭제
  
    For Each rngC In rngAll
        rngC = Application.Substitute(rngC, "-", "")
    Next rngC
   
    Set rngAll = Nothing  '// 변수 초기화
    MsgBox "완료"
End Sub

전화번호 정리하는 VBA

엑셀에 있는 여러가지 전화번호 리스트를 보면 숫자로만 되어 있는 경우도 있고, 032)354-2568 처럼 되어 있는 경우도 있고 051-2345-9857 처럼 되어 있는 경우도 있다.

휴대폰번호를 포함하여 전부 다시 정렬하고 싶을 때 사용하려고 작성해봤다.

VBA는 엑셀함수와는 달리 약간의 코딩으로 원하는 결과를 매우 편하게 얻을 수 있다. 도움이 되겠다 싶은 것을 하나 하나 정리해두면 나중에 일을 편하게 할 수 있을 것 같다.

• Sub 전화번호정렬()

      Dim strU As String      '// 문자를 합쳐갈 변수

      Dim i As Integer        '// 전체 문자길이 만큼 반복할 변수

      Dim rngC As Range       '// 각 Line 변수

      Dim rngAll As Range     '// 전체 범위 지정

      

      Application.ScreenUpdating = False    '// 화면 업데이트 (일시) 중지

      Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))   '// A2 셀부터 A열의 마지막 셀까지

          

      For Each rngC In rngAll

          For i = 1 To Len(rngC)                      '// 전체 문자길이 만큼 반복

                  If IsNumeric(Mid(rngC, i, 1)) Then  '// 문자열이 숫자일 경우

                      strU = strU & Mid(rngC, i, 1)   '// 각 숫자를 합쳐감

                  End If

          Next i

        

          Select Case Len(strU)     '// IF 문에서 숫자만 추출된 strU 의 길이 검사

              Case 8      '// 전국대표번호 처럼 8자리로 된 경우

                  rngC.Offset(0, 1) = Format(strU, "0000-0000")

              Case 9

                  rngC.Offset(0, 1) = Format(strU, "00-000-0000")

              Case 10

                  If Left(strU, 2) = "02" Then

                      rngC.Offset(0, 1) = Format(strU, "00-0000-0000")

                  Else

                      rngC.Offset(0, 1) = Format(strU, "000-000-0000")

                  End If

              Case 11

                  rngC.Offset(0, 1) = Format(strU, "000-0000-0000")

          End Select

          

          strU = ""   '// 값을 기록했으니까 초기화가 필요함

      Next rngC

      

      Set rngAll = Nothing  '// 변수 초기화

      MsgBox "정리완료"

  
  

  End Sub

외부 엑셀파일에서 자료를 가져오는 방법이다.

서식까지 그대로 가져오는 방법과 SQL 을 이용하여 가져오는 방법이다.

A1 셀에서 값을 a, b 로 다르게 적어주면 가져오는 파일의 내용이 달라진다.

Excel_Get.zip

Sub ExcelFile_Get()
    Dim getFile As Object
    Dim FilePath As String          '// 파일 경로 변수
    Dim FileName As String         '// 가져올 엑셀 파일명 변수
   
    On Error Resume Next
    FilePath = ThisWorkbook.Path + "\"  '// 현재 파일 경로
   
    If [A1].Text = "a" Then
        FileName = "Asample.xlsx"      '// 다른 엑셀파일
    ElseIf [A1].Text = "b" Then
        FileName = "Bsample.xlsx"      '// 다른 엑셀파일
    Else
        MsgBox " 가져올 파일을 선택하지 않았습니다"
        Exit Sub
    End If
   
    Set getFile = GetObject(FilePath & FileName)
    With ActiveWorkbook.ActiveSheet.Range("A5")    '// A5열부터 데이터 출력
        .CurrentRegion.Clear    '// 현재 존재하는 값을 전부 삭제
        getFile.Sheets([A2].Text).UsedRange.Copy [A5]
        getFile.Close False
    End With
    Set getFile = Nothing
End Sub

또다른 방법은 데이터베이스처럼 가져오는 방법이다.

이 경우에는 서식유지까지는 안된다.

Sub ExcelFileData_Get()
'// This sub will pull data from an external .xlsx file.
'// The ADO 6.0 object library reference must be loaded.
    Dim conn As Object     '// 연결변수 선언
    Dim RS As Object
    Dim strSQL As String              '// SQL 문을 위한 변수
    Dim FilePath As String          '// 파일 경로 변수
    Dim FileName As String         '// 가져올 엑셀 파일명 변수
    Dim i As Long
   
    FilePath = ThisWorkbook.Path + "\"  '// 현재 파일 경로
    If [A1].Text = "a" Then
        FileName = "Asample.xlsx"      '// 다른 엑셀파일
    ElseIf [A1].Text = "b" Then
        FileName = "Bsample.xlsx"      '// 다른 엑셀파일
    Else
'        FileName = ActiveWorkbook.Name      '// 같은 엑셀파일(현재 엑셀화면에 활성화된 파일)
        MsgBox " 가져올 데이터를 선택하지 않았습니다"
        Exit Sub
    End If
  
    Set RS = CreateObject("ADODB.Recordset")
    Set conn = CreateObject("ADODB.Connection")
   
    With conn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & FilePath & FileName & ";" & _
            "Extended Properties=Excel 12.0;"
        .Open
    End With
   
    strSQL = "SELECT * FROM [Data$] "           '// 엑셀시트이면 뒤에 $ 를 붙인다. Data Sheet 가 존재해야 한다.
   
    Set RS = conn.Execute(strSQL)
   
    With ActiveWorkbook.ActiveSheet.Range("A5")    '// A5열부터 데이터 출력
        .CurrentRegion.Clear    '// 현재 존재하는 값을 전부 삭제
       
        For i = 0 To RS.Fields.Count - 1    '// 레코드셋 제목 전부 가져오기
            .Offset(0, i).Value = RS.Fields(i).Name
        Next i
       
        .Offset(1, 0).CopyFromRecordset RS
       
    End With
   
    RS.Close
    conn.Close
    Set RS = Nothing
    Set conn = Nothing
   
End Sub

인도영화 자막은 하이픈 처리가 제대로 안된 것이 많다.

오랫만에 자막 좀 뒤져보다가 인도영화 자막 하이픈 처리한다고 엑셀로 수작업 처리했던 것이 있어서 VBA로 코드를 만들어봤다.

영화자막 하이픈수정처리.xlsm

Sub 자막하이픈수정()
    Dim rngC As Range
    Dim rngAll As Range
    Dim n As Long
   
    Set rngAll = Range([B2], Cells(Rows.Count, "B").End(3))
    Columns("B:C").NumberFormat = "@"     '// 텍스트 서식 지정
    If Cells(Rows.Count, "B").End(3).Row = 1 Then
        MsgBox "수정할 자막이 없습니다"
        Exit Sub
    End If
    rngAll.Offset(0, 1).ClearContents
    For Each rngC In rngAll
        If InStr(rngC, "<br>") Then
            If Not InStr(rngC, "-") And InStr(rngC.Offset(1, 0), "-") Then
                rngC.Offset(0, 1) = "- " & rngC
                rngC.Interior.ColorIndex = 36
                n = n + 1
            Else
                rngC.Offset(0, 1) = rngC
                rngC.Interior.ColorIndex = xlNone
            End If
        Else
            rngC.Offset(0, 1) = rngC
            rngC.Interior.ColorIndex = xlNone
        End If
    Next rngC
   
    Set rngAll = Nothing
    If n = 0 Then
        MsgBox "- 추가 대상이 없습니다"
    Else
        MsgBox n & "개 수정했습니다"
    End If
End Sub

Sub 결과비우기()
    Range([B2], Cells(Rows.Count, "B").End(3)).Offset(0, 1).ClearContents
End Sub

위키피디아(http://en.wikipedia.org/wiki/ASCII)에 아스키 코드값이 나온 자료가 있어서 가져왔다.

2진수, 8진수, 10진수, Hex 값이 같이 나와서 값을 찾아볼 때 매우 편리할 거 같다.

셀의 전체 구간이 아니라 부분 구간을 설정하고 그 구간에 중복되는 셀을 제거하는 VBA 코드를 만들어야 했다.

F8키를 눌러서 계속 검증 작업을 해보는데 문제가 생긴다.

확인결과 RemoveDuplicates 함수가 문제를 일으킨다.

이 함수는 머리글이 있고 전체에서 중복을 제거할 때 유용한가 보다.

중복제거를 제대로 못하는 경우도 있는 거 같아서 혹시나 하고 Sort 를 해서 중복을 제거하고 다시 원상태로 돌리는 작업을 진행했다.

그런데 전체구간의 중복을 체크하다보니 원하지 않는 셀이 중복이라고 삭제되는 경우가 생겨버렸다.

이걸 해결하려고 구간을 설정하고 반복해서 중복을 제거하라고 했던 것인데 잘 안되니까

생고생 끝에 다음 코드를 만들었다.

rngC 이 한행이 변하면서 구간내에서 6개의 셀을 다시 범위 설정해서 계속해서 반복적으로 돌려가면서 작업을 하는 것이다.

Sub 중복제거()
    Dim sTotal, eTotal As Long
    Dim i, n, k As Long
    Dim rngC, rngT As Range
    Dim rngAll As Range
    Dim rngDB As Range
   
    Application.ScreenUpdating = False      '// 화면 업데이트 (일시)정지
    sTotal = Cells(Rows.Count, "A").End(3).Row
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    For Each rngC In rngAll
        Set rngDB = Range(rngC, rngC.Offset(5))
        For Each rngT In rngDB
             i = i + 1
            rngT.Offset(, 1) = i
        Next rngT
        Range(rngC, rngC.Offset(5, 1)).Sort key1:=rngDB, order1:=1, Header:=xlNo
        For n = rngC.Offset(5).Row To rngC.Row Step -1
            If Cells(n, 1) = Cells(n - 1, 1) Then
                Cells(n, 1).EntireRow.Delete
                k = k + 1
            End If
        Next n
        Range(rngC, rngC.Offset(5 - k, 1)).Sort key1:=Range(rngC.Offset(0, 1), rngC.Offset(5 - k, 1)), order1:=1, Header:=xlNo
        Range(rngC.Offset(, 1), rngC.Offset(, 1).End(4)).ClearContents
                     
        i = 0   '// 초기화
        k = 0   '// 초기화   

    Next rngC
   
    eTotal = Cells(Rows.Count, "A").End(3).Row
    MsgBox sTotal - eTotal & " 개 제거"

End Sub.

다른 시트 자료를 SQL 방식으로 가져오는 걸 지난번에 한번 해봤는데 네이버지식인에 올라온 문의사항을 보니 AutoFilter 를 이용하는 것보다 SQL 형태로 가져오면 좋겠다는 생각이 들어서 다시 한번 해봤다.

그러면서 SQL 조건에서 자료형식 체크하는 걸 추가했다.

내가 잘 몰라서인지 서식까지 그대로 복사를 하지 못했다.

Help_FileData.xlsm

Sub ExcelFileData_Get()
'// 외부 엑셀파일을 가져올 수도 있고 다른 시트 내용을 가져올 수도 있음
'// The ADO 6.0 object library reference must be loaded.
    Dim DBconn As ADODB.Connection      '// 연결변수 선언
    Dim RS As ADODB.Recordset
    Dim strSQL As String              '// SQL 문을 위한 변수
    Dim sht1 As Worksheet           '// 워크시트 변수
    Dim RSCount As Integer          '// 총 레코드(행)의 수 변수
    Dim FieldCount As Integer       '// 총 필드(열)의 수 변수
    Dim i, j, sRow As Integer
    Dim NoRecords As Boolean
    Dim FilePath As String          '// 파일 경로 변수
    Dim FileName As String         '// 가져올 엑셀 파일명 변수
    Dim a, b, c, d, S, T, U As String
       
    Set sht1 = Sheets("Main")      '// 현재 작업중인 워크시트 명
    Set DBconn = New ADODB.Connection
   
    FilePath = ThisWorkbook.Path + "\"  '// 현재 파일 경로
'    FileName = "Asample.xlsx"      '// 다른 엑셀파일명을 적어주고 주석을 제거하려면 아래 행은 주석처리 해야 함
    FileName = ActiveWorkbook.Name      '// 같은 엑셀파일(현재 엑셀화면에 활성화된 파일)
   
    S = sht1.Range("A3")      '// 업체코드
    T = sht1.Range("B3")      '// 업체명
    U = sht1.Range("C3")      '// 품목코드
    a = sht1.Range("D3")     '// 최종출고
    b = sht1.Range("E3")     '// 최종출고
    c = sht1.Range("F3")     '// 적용일자
    d = sht1.Range("G3")     '// 적용일자
    
    strSQL = "SELECT * FROM [Data$] "           '// 엑셀시트이면 뒤에 $ 를 붙인다. Data Sheet 가 존재해야 한다.
    If T <> vbNullString Then strSQL = strSQL & "Where 업체명=""" & T & """"         '// 업체명 필드 (텍스트 변수 처리)
    If S <> vbNullString Then
        If IsNumeric(S) = False Then
            MsgBox "업체코드는 숫자를 입력하셔야 합니다"
            Exit Sub
        Else
            strSQL = strSQL & " and 업체코드=" & S & ""        '// 업체코드 필드 (숫자 변수 처리)
        End If
    End If
    If U <> vbNullString Then
        If IsNumeric(S) = False Then
            MsgBox "품목코드는 숫자를 입력하셔야 합니다"
            Exit Sub
        Else
            strSQL = strSQL & " and 품목코드=" & U & ""        '// 품목코드 필드 (숫자 변수 처리)
        End If
    End If
   
    If a <> vbNullString And b <> vbNullString Then
        strSQL = strSQL & "And (최종출고일 Between #" & a & "# And #" & b & "#) "     '// 최종출고 a~b 일까지 (날짜변수 처리)
    ElseIf a <> vbNullString And b = vbNullString Then
        strSQL = strSQL & "And (최종출고 = #" & a & "#) "     '// 최종출고 a (날짜변수 처리)
    ElseIf a = vbNullString And b <> vbNullString Then
        strSQL = strSQL & "And (최종출고 = #" & b & "#) "     '// 최종출고 b (날짜변수 처리)
    End If
   
    If c <> vbNullString And d <> vbNullString Then
        strSQL = strSQL & "And (적용일자 Between #" & c & "# And #" & d & "#) "     '// 입고일자는 a~b 일까지 (날짜변수 처리)
    ElseIf c <> vbNullString And d = vbNullString Then
        strSQL = strSQL & "And (적용일자 = #" & c & "#) "     '// 입고일 a (날짜변수 처리)
    ElseIf c = vbNullString And d <> vbNullString Then
        strSQL = strSQL & "And (적용일자 = #" & d & "#) "     '// 입고일 a (날짜변수 처리)
    End If
'    strSQL = strSQL & "Order By 업체명"       '// 업체명 기준으로 오름차순 정렬
   
    With DBconn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & FilePath & FileName & ";" & _
            "Extended Properties=Excel 12.0;"
        .Open
    End With

    Set RS = DBconn.Execute(strSQL)
   
    With ActiveWorkbook.ActiveSheet.Range("A5")    '// A5열부터 데이터 출력
        .CurrentRegion.Offset(1).ClearContents    '// 현재 존재하는 값을 전부 삭제      
       
        NoRecords = False
        With RS
            FieldCount = .Fields.Count      '// 전체 필드(제목열)의 개수
            For i = 0 To .Fields.Count - 1     '// 레코드셋 제목 전부 가져오기
                sht1.Cells(5, 1).Offset(, i) = .Fields(i).Name
            Next i

               sRow = Cells(Rows.Count, "A").End(3)(2).Row     '// 첫번째 값을 뿌릴 행의 값
           
            If Not (.BOF And .EOF) Then
                NoRecords = False
                .MoveFirst
                While Not .EOF
                    .MoveNext
                    RSCount = RSCount + 1   '// 전체 레코드수 구하기
                Wend        '// 주어진 조건이 True인 동안은 일련의 문을 계속 실행
            Else
                NoRecords = True
                MsgBox ("가져올 자료가 없음")
                Exit Sub
            End If
           
            .MoveFirst      '// 레코드의 처음으로 이동
            While Not .EOF      '// EOF 를 만나기 전까지 계속 반복하라
                For i = sRow To sRow + RSCount - 1 Step 1   '// 총 행의 수만큼 반복
                    For j = 1 To FieldCount Step 1      '// 총 열의 수만큼 반복
                        sht1.Cells(i, j) = .Fields(j - 1)        '// 셀에 값을 기록하라
                    Next j
                    .MoveNext   '// 다음 레코드(행)으로 이동
                Next i
            Wend
        End With
    End With
    RS.Close
    DBconn.Close
    Set RS = Nothing
    Set DBconn = Nothing
   
    MsgBox RSCount & "개 데이터 가져오기 완료"
End Sub

그동안 개발도구 탭 표시도 하지 않고 매크로 버튼은 [삽입] - [도형]을 이용해서 작업을 했는데

개발도구 탭을 이용하여 작업하고 싶어서 개발도구 탭을 화면에 표시하는 방법을 알아봤다.

매크로버튼을 만드는데 도형에 있는 그림으로 만들면 셀을 삭제하면 매크로 버튼이 같이 날라가는 경우가 생긴다.

하지만 개발도구 - [삽입] 에서 선택한 아이콘으로 만들면 행을 삭제해도 버튼은 삭제되지 않는다.

셀을 삭제해도 매크로 실행버튼은 그대로 유지되게 하는 방법이다.

숫자를 일부러 적어봤다.

행삭제를 했는데도 불구하고 버튼은 그대로 유지된다.

네이버지식인에 올라온 환율 파싱 질문을 보고 한번 시도를 해봤다.

파싱하는 것은 WaitForResponse 하는 부분까지를 알아내는 것과 그 뒤의 처리로 분류할 수가 있다.

난 아직 앞부분 처리하는 건 잘 모른다.

뒷부분 처리는 Instr함수, Split 함수, Replace 함수 그리고 debug.print 기능만 이용하면 원하는 걸 얼마든지 추출해 낼 수가 있다.

내가 뽑아내고 싶은 값이 무엇인지에 따라 해당되는 걸 다시 줄여서 Split 함수를 이용하여 원하는 구간을 줄여나간다.

가령 1,097.20 이란 값만 뽑아내고 싶다면 ....

직접실행창(Ctrl + G) 에 뿌려진 결과를 보고 일정한 규칙을 찾아내면 된다.

<td> 라는 걸 Split 한다고 하면 내가 원하는 <td>는 몇번째에 있는지 한번 보자.

4번째에 있다. Split 함수는 Split(T,"<td>")(0) 를 하면 <td>를 기준으로 (0)은 앞의 것을 반환한다.

뒤의 것을 반환하는 것은 <td>가 여러개가 존재하므로 (4) 를 해주어야 한다.

이제 Debug.Print T를 해보면 결과는 1,097.20</td> 를 화면에 출력해준다.

원하는 결과는 1,097.20 이므로 </td>의 앞부분이다. Split 함수 기준으로 앞부분은 (0) 이라고 했으므로

한번에 처리하는 Split 함수는 T = Split(Split(T, "<td>")(4), "</td>")(0) 가 된다.

얻어야 할 결과값이 4.70 이라면 ....

<td class="tx_l"><span class="down"><span>??/span> <span class="num">4.70</span></span></td>

에서 Replace 함수를 이용하여 제거해서 결과를 얻거나 범위를 좁혀서 Split 함수를 이용하면 된다.

환율데이터가져오기.xlsm

Sub 환율파싱()
    Dim T As String
    Dim C As Variant
    Dim R As Variant
    Dim n As Long

    Dim Winhttp As Object
    Set Winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")

    With Winhttp
        .Open "GET", "http://search.naver.com/search.naver?sm=tab_hty.top&where=nexearch&ie=utf8&query=%ED%99%98%EC%9C%A8"
        .SetRequestHeader "Host", "www.NAVER.com"
        .Send
        .WaitForResponse

        T = StrConv(.ResponseBody, vbUnicode)
         .WaitForResponse
'        Debug.Print T
        T = Split(Split(T, Chr(60) + "em" + Chr(62) + "USD")(1), "last")(0)
'        Debug.Print T
        T = Split(T, "</th>")(1)
        T = Replace(T, "<strong class=""down"">", "")
        T = Replace(T, "</strong>", "")
        T = Replace(T, " class=""tx_l""", "")
        T = Replace(T, "<span class=""down""><span>??/span> <span class=""num"">", "")
        T = Replace(T, "<span class=""percent down"">", "")
        T = Replace(T, "</span>", "")
        T = Replace(T, "<td class=""", "")
        Debug.Print T
       
        With Range("B2:H2")
            .Value = Array("매매기준율", "전일대비", "등락율", "현찰살때", "현찰팔때", "송금보낼때", "송금받을때")
            .HorizontalAlignment = xlCenter
            .Interior.ColorIndex = 36
        End With
       
        R = Split(T, "<td>")
        For n = 1 To UBound(R)
            Cells(3, n + 1) = Split(R(n), "</td>")(0)
        Next n
    End With
    Columns("A:H").AutoFit
 End Sub

SQL 기능을 이용하여 원하는 데이터 가져오기

다른 파일이나 같은 파일내 다른 시트에서 자료를 데이터베이스처럼 가져오는 기능을 구현한 것이다.

외국자료를 참조하였고, 필요한 기능을 보강하고, 편의성을 중점적으로 보강한 거의 완벽에 가까운 자료이다.

Where 조건문을 포함할 수도 있고 포함하지 않을 수 있는 경우를 모두 고려하여 만들려고 하는데, 사과이름 변수는 꼭 포함해야만 동작이 된다. 좀 더 공부하면 이 부분도 해결할 수 있지 않을까?

등급, 입고일, 출하일 은 모두 빈공백으로 설정하면 Where 검색조건에서 제외되도록 했다.

FileData_Get.xlsm

Asample.xlsx

Sub ExcelFileData_Get()
'// This sub will pull data from an external .xlsx file.
'// The ADO 6.0 object library reference must be loaded.
    Dim conn As ADODB.Connection      '// 연결변수 선언
    Dim RS As ADODB.Recordset
    Dim strSQL As String              '// SQL 문을 위한 변수
    Dim sht1 As Worksheet           '// 워크시트 변수
    Dim RSCount As Integer          '// 총 레코드(행)의 수 변수 선언
    Dim FieldCount As Integer       '// 총 필드(열)의 수 변수 선언
    Dim i, j, sRow As Integer
    Dim NoRecords As Boolean
    Dim FilePath As String          '// 파일 경로 변수
    Dim FileName As String         '// 가져올 엑셀 파일명 변수
    Dim a, b, c, d, T, U As String
       
    Set sht1 = Sheets("Main")      '// 현재 작업중인 워크시트 명
    Set conn = New ADODB.Connection
   
    FilePath = ThisWorkbook.Path + "\"  '// 현재 파일 경로
'    FileName = "Asample.xlsx"      '// 다른 엑셀파일
    FileName = ActiveWorkbook.Name      '// 같은 엑셀파일(현재 엑셀화면에 활성화된 파일)
   
    T = sht1.Range("B3")      '// 사과이름
    U = sht1.Range("C3")      '// 등급
    a = sht1.Range("D3")     '// 입고일
    b = sht1.Range("E3")     '// 입고일
    c = sht1.Range("F3")     '// 출하일
    d = sht1.Range("G3")     '// 출하일
    
    strSQL = "SELECT * FROM [Data$] "           '// 엑셀시트이면 뒤에 $ 를 붙인다. Data Sheet 가 존재해야 한다.
    If T <> vbNullString Then strSQL = strSQL & "Where 사과이름=""" & T & """"     '// 사과이름 필드 (텍스트 변수 처리)
    If U <> vbNullString Then strSQL = strSQL & " and 등급=""" & U & """"        '// 등급 필드 (텍스트 변수 처리)
   
    If a <> vbNullString And b <> vbNullString Then
        strSQL = strSQL & "And (입고일 Between #" & a & "# And #" & b & "#) "  '// 입고일 a~b 일까지 (날짜변수 처리)
    ElseIf a <> vbNullString And b = vbNullString Then
        strSQL = strSQL & "And (입고일 = #" & a & "#) "     '// 입고일 a (날짜변수 처리)
    ElseIf a = vbNullString And b <> vbNullString Then
        strSQL = strSQL & "And (입고일 = #" & b & "#) "     '// 입고일 b (날짜변수 처리)
    End If
   
    If c <> vbNullString And d <> vbNullString Then
        strSQL = strSQL & "And (출하일 Between #" & c & "# And #" & d & "#) "    '// 입고일 a~b 일까지 (날짜변수 처리)
    ElseIf c <> vbNullString And d = vbNullString Then
        strSQL = strSQL & "And (출하일 = #" & c & "#) "     '// 입고일 a (날짜변수 처리)
    ElseIf c = vbNullString And d <> vbNullString Then
        strSQL = strSQL & "And (출하일 = #" & d & "#) "     '// 입고일 a (날짜변수 처리)
    End If
'    strSQL = strSQL & "Order By 사과이름"       '// 사과이름 기준으로 오름차순 정렬
   
    With conn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & FilePath & FileName & ";" & _
            "Extended Properties=Excel 12.0;"
        .Open
    End With
   
    Set RS = conn.Execute(strSQL)
   
    With ActiveWorkbook.ActiveSheet.Range("A5")    '// A5열부터 데이터 출력
        .CurrentRegion.Offset(1).ClearContents    '// 현재 존재하는 값을 전부 삭제
        sRow = Cells(Rows.Count, "A").End(3)(2).Row     '// 첫번째 값을 뿌릴 행의 값
       
        NoRecords = False
        With RS
            FieldCount = .Fields.Count      '// 전체 필드(제목열)의 개수
            For i = 0 To .Fields.Count - 1     '// 레코드셋 제목 전부 가져오기
                sht1.Cells(5, 1).Offset(, i) = .Fields(i).Name
            Next i
           
            If Not (.BOF And .EOF) Then
                NoRecords = False
                .MoveFirst
                While Not .EOF
                    .MoveNext
                    RSCount = RSCount + 1   '// 전체 레코드수 구하기
                Wend        '// 주어진 조건이 True인 동안은 일련의 문을 계속 실행
            Else
                NoRecords = True
                MsgBox ("No records in target")
                Exit Sub
            End If
           
            .MoveFirst      '// 레코드의 처음으로 이동
            While Not .EOF      '// EOF 를 만나기 전까지 계속 반복하라
                For i = sRow To sRow + RSCount - 1 Step 1   '// 총 행의 수만큼 반복
                    For j = 1 To FieldCount Step 1      '// 총 열의 수만큼 반복
                        sht1.Cells(i, j) = .Fields(j - 1)        '// 셀에 값을 기록하라
                    Next j
                    .MoveNext   '// 다음 레코드(행)으로 이동
                Next i
            Wend
        End With
    End With
    RS.Close
    conn.Close
    Set RS = Nothing
    Set conn = Nothing
   
    MsgBox RSCount & "개 데이터 가져오기 완료"
End Sub

작업량의 시간을 그래프처럼 보기좋게 자동으로 찾아서 표시를 해주고 싶은 경우에 사용할 수 있는 VBA 코드입니다.

작업량실적그래프표시.xlsm

Sub 작업량실적그래프표시()
    Dim rngDB As Range

    Dim lookup_array As Range
    Dim rngC As Range
    Dim n, endRow As Integer
   
    Set rngDB = Range([N3], Cells(Rows.Count, "N").End(3))
    Set lookup_array = Range("B2", "K2")
    endRow = Cells(Rows.Count, "N").End(3).Row
    Range([B3], Cells(endRow, "K")).Interior.Color = xlNone    '// 색상 초기화
   
    For Each rngC In rngDB
        n = WorksheetFunction.Match(rngC, lookup_array, 0)
        '// MACTH(현재 표에서 찾고자 하는 셀, lookup_array,0) 는 일치하는 위치가 몇번째인지를 반환
        '// lookup_array 를 행/열의 구간범위내에서 몇번째인지 반환
        '// 0 (FALSE)은 match type으로 정확하게 일치하는 값만 가져오라는 의미
'        MsgBox n    '// 직접 숫자를 확인하고 싶다면 ...
        Cells(rngC.Row, 2).Resize(1, n).Interior.Color = RGB(255, 210, 210)
        '// RGB 색상표 색상을 쉽게 찾으려면 http://link2me.tistory.com/591 참조
    Next rngC
   
End Sub

아직도 범위 지정을 신경쓰지 않고 한방에 훅하고 해결을 못하고 있다.

Sheet 와 Sheet 간에 데이터를 복사하거나 참조하여 계산하거나 할 때 셀의 구간범위 지정하는 것 때문에 신경쓰는 일이 없도록 샘플을 만들었다.

Range 를 단순하게 설정하는 것은 아주 쉽고 엄청많다. 하지만 Sheet 가 서로 다를 때 구간설정하는 것을 조금이라도 실수를 하면 에러가 발생하는 걸 몇차례 경험했다.

엑셀 VBA 를 조금씩 배워가면서 터특한 것을 중심으로 더 나은 VBA 코드로 만들 수 있는 것은 재정리를 하거나 삭제를 해둬야겠다. 막상 참고해서 뭘 좀 하려고 하면 별 도움이 안되는 것도 눈에 보인다.

범위설정을 다음부터는 신경쓰지 않고 한번에 해결하기 위해서 기록해둔다.

range_setting.vbs

Sub 구간범위지정()
    Dim sht1, sht2     As Worksheet   '// 시트(Sheet)를 넣을 변수
    Dim rngDB, rngAll As Range
    Dim rngT, rngC As Range
    Dim i&, n&, startRow, endRow As Long   '// 오버플로우를 경험후 무조건 Long 으로 설정
     Dim openMsg As String
   

    Application.StatusBar = True   

    openMsg = "시작행을 입력하는 방식이면 Yes를 눌러주세요 " & vbCr & vbCr
    openMsg = openMsg & "기본 시작행을 선택하려면 No를 눌러주세요" & vbCr
    If MsgBox(openMsg, vbYesNo) = vbYes Then
        startRow = InputBox("시작할 행의 수를 입력하세요")
        If startRow = vbNullString Then Exit Sub           '// 취소 선택시 매크로 중단
    Else
        startRow = 2    '// 시작행 지정
    End If   
    If Not IsNumeric(startRow) Then Exit Sub     '// 입력한 값이 숫자가 아닌 경우 매크로 중단
   
    Set sht1 = Sheets("data")   '// data 워크시트를 sht1 으로 지정
    Set sht2 = Sheets("category") '// category 워크시트를 sht2 로 지정
    Set rngAll = sht1.Range(sht1.Cells(startRow, "D"), sht1.Cells(Rows.Count, "D").End(3))
    Set rngDB = sht2.Range(sht2.Cells(2, "C"), sht2.Cells(Rows.Count, "C").End(3))
    endRow = sht1.Cells(Rows.Count, "D").End(3).Row    '// D열의 값이 있는 마지막셀의 행번호

    실제 계산을 위한 코딩

    결과가 끝났음을 알려주는 Msgbox 처리

End sub

계속 코드를 만들어서 사용하다보니 이것도 좀 불편하다.

그래서 새롭게 정리해서 사용하는 코드는 아래와 같다.

물론 위의 코드와 사용하는 용도는 약간 다르지만 sRow, eRow 를 Selection 개념이랑 같이 적용하여 편리하다.

    Dim C, rngAll As Range
    Dim sRow, eRow As Long    '// 시작할 행의 변수
    Dim cnt%
    Dim myValue As String
    Dim v
   
    Application.DisplayStatusBar = True
    cnt = Selection.Rows.Count
    sRow = Selection.Row
    myValue = sRow & "/" & sRow + cnt - 1
    v = InputBox("시작할 행의 수를 입력하세요", , myValue)
    If InStr(v, "/") > 0 Then
        sRow = Trim(Split(v, "/")(0))
        eRow = Trim(Split(v, "/")(1))  '// 마지막 행
    Else
        sRow = v
    End If
    If sRow = vbNullString Then Exit Sub           '// 취소 선택시 매크로 중단
    If sRow <= 2 Then sRow = 2
    If Not IsNumeric(sRow) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우 매크로 중단
   
    If eRow Then
        Set rngAll = Range(Cells(sRow, "A"), Cells(eRow, "A"))  '// 열의 끝행을 지정
    Else
        Set rngAll = Range(Cells(sRow, "A"), Cells(Rows.Count, "A").End(3))
    End If

인터넷에서 자료를 찾다보면 번호가 나오고 뒤에 내용이 나오는 경우가 있습니다.

이럴 경우 번호를 일일이 지우려고 하니까 좀 짜증나더군요.

그래서 간단하게 만들어본 VBA 코드입니다.

Sub 앞번호제거()
    Dim rngC As Range
    Dim rngAll As Range
   
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
   
    For Each rngC In rngAll
        If IsNumeric(Left(rngC, 1)) Then
            rngC.Offset(, 1) = Trim(Mid(rngC, Len(Split(rngC, ".")(0)) + 2, Len(rngC)))
        Else
            rngC.Offset(, 1) = rngC
        End If
    Next rngC
   
End Sub

내 컴퓨터의 MAC 주소를 가져오는 VBA 코드입니다.

구글링해서 외국사이트에서 찾아서 테스트 해봤더니 잘 되네요

먼저 내 PC의 MAC 주소가 뭔지 알아보겠습니다.

MAC(Media Access Control Address) 는 컴퓨터의 LAN 카드에 저장된 고유식별번호 입니다.

우리가 접속하는 인터넷 브라우저는 IP통신(3 Layer)을 합니다.

IP통신으로는 내 컴퓨터의 MAC주소 정보(2 Layer)는 알 수가 없습니다.

윈도우모양 키 + R 를 누르면 나오는 창에다가 cmd 를 입력하고 엔터키를 치면 아래 화면이 나옵니다.

ipconfig /all 을 입력하면

내 컴퓨터의 MAC주소가 뭔지 알려줍니다.

이 정보를 엑셀에서 가져오는 VBA 코드입니다.

Sub getMACaddress()
    Dim strComputer As String
    Dim objWMIService As Object
    Dim colAdapters As Object
    Dim objAdapter As Object
   
    Worksheets("Setting").Cells(1, 2).Offset(1).ClearContents
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "!\\" & strComputer & "\root\cimv2")
    Set colAdapters = objWMIService.ExecQuery _
    ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
   
    For Each objAdapter In colAdapters
        MsgBox "Physical address: " & objAdapter.MACAddress
'        Worksheets("Setting").Cells(Rows.Count, 2).End(3)(2) = objAdapter.MACAddress
    Next objAdapter
End Sub

실행(F5)를 하면 팝업창이 뜨는데 정보를 비교하면 똑같다는 걸 알 수 있습니다.

getMACaddress.vbs

필요하신 분은 첨부파일 받아가세요.

표에서 특정한 값이 들어 있는 행만 굵은선으로 테두리를 씌우고 싶은 경우에 대한 문의 사항이 있어서 작성해봤습니다.

특정숫자테두리선.xlsm

VBA 코드는 아래와 같습니다.

VBA 코드 작업을 하다보니 구간범위 설정할 때 Cells(Rows.Count,"G").End(3) 과 같은 걸 잘못 지정하면 원하지 않는 결과가 나올 수도 있습니다.

무슨 말인고 하면 G열의 데이터가 들어있는 마지막셀을 찾으라는 것이라서 만약 G열의 데이터가 전부 삭제되고 없는 경우에는 표 전체에 적용했던 것이 한줄만 적용될 수도 있다는 겁니다.

그래서 가장 마지막 라인의 값이 들어있는 열의 행의 값을 저장했다가 그걸 이용하면 문제가 생기지 않습니다.

Range(rngC, rngC.Offset(, 6)) 의 의미는 rngC 현재 셀, rngC.offset(,6) 은 rngC.offset(0,6) 을 줄여서 사용한 것이며, offset(0,6) 의 의미는 현재셀로부터 행은 변동이 없고, 열쪽으로 6번 우측이라는 뜻입니다.

따라서 Range(시작셀, 마지막셀)은 같은 행에서 열이 7개를 포함하고 있다는 겁니다.

열의 숫자가 다르면 늘려주거나 줄여주면 됩니다.

Sub Thickborder()
    Dim rngC As Range       '// 행을 반복할 변수
    Dim rngAll As Range     '// 표 전체 범위 지정
    Dim rngDB As Range      '// 같은 행의 구간범위 지정
    Dim endRow As Long      '// 표(값이 들어있는) 마지막 행
    Dim k As Integer
       
    Set rngAll = Range([A1], Cells(Rows.Count, "A").End(3)) '// 표의 전체범위 구간 지정
    endRow = Cells(Rows.Count, "A").End(3).Row
    Range([A1], Cells(endRow, "G")).Borders.LineStyle = xlLineStyleNone
    '// 표의 전체 범위 선지정 전부 해제
   
    For Each rngC In rngAll
        If rngC = 1 Then
            Set rngDB = Range(rngC, rngC.Offset(, 6))   '// 같은 행의 범위 지정
            rngDB.BorderAround LineStyle:=xlContinuous, Weight:=xlThick, ColorIndex:=14
            '// 외곽 테두리 선만 원하는 색상으로 지정
            k = k + 1
        End If
    Next rngC
   
    If k > 0 Then
        MsgBox k & " 개 테두리선 표시"
    Else
        MsgBox "표시할 영역이 없음"
    End If
End Sub

엑셀에서 수식의 결과를 구하고 나면 깔끔한 선그리기로 모양을 예쁘게 하고 싶을 경우가 있습니다.

borders.xlsm

Sub 테두리선그리기()
    Dim rngAll As Range
   
    Set rngAll = Range([B2], [E10]) '// 선그릴 구간범위 지정
   
    Range([A1], Cells(Rows.Count, "K")).Borders.LineStyle = xlLineStyleNone
    '// A1 에서 K열의 마지막행까지의 선을 그리지 말아라, 즉 선을 모두 지워라
   
    With rngAll.Borders    '// 구간범위의 선(Borders) 그리기
        .LineStyle = 1        '// 실선(xlContinuous)으로 그려라
        .ColorIndex = 14    '// 색상은 http://link2me.tistory.com/260 참조
        .Weight = xlThin    '// xlThin : 가는 실선, xlThick : 굵은 실선
    End With
   
    rngAll.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=22
    '// 외곽선 그리기
End Sub

LineStyle 은

xlContinuous (실선), xlDash (파선), xlDashDot (파선과 점선이 교대로 나타나는 형태), xlDashDotDot (파선과 두개의 점선이 교대로 나타나는 형태), xlDot (점선), xlDouble (이중선), xlLineStyleNone (선 없음), xlSlantDshDot (기울어진 파선)

Weight 는

xlHairline (가장 가는 실선), xlThin (가는 실선), xlMedium (보통굵기의 선), xlThick (굵은 실선)

* 가장 가는 실선(xlHairline) 으로 지정하면 거의 점선처럼 보인다.

* LineStyle 을 지정하지 않고 테스트해보면 된다.

ColorIndex : 테두리 선의 색상을 색 번호 또는 내장 상수를 이용해서 지정

xlColorIndexAutomatic (자동 색상), xlColorIndexNone (색상을 적용하지 않음)

ColorIndex 색상의 숫자에 따른 색깔이 어떻게 표시되는지 확인하려면 http://link2me.tistory.com/260

을 참조하세요