'업무 능력 향상/엑셀 VBA 활용'에 해당되는 글 113건

행높이와 열너비 저장 및 복원

엑셀에서 복사를 하면 그대로 서식까지 복사가 되면서 행높이, 열너비까지 그대로 복사가 되는 경우라면 고민을 할 필요가 없습니다.

그런데 서식은 복사되는데 행높이, 열너비 정보는 가져오지 못하는 경우가 있어서 이걸 해결하기 위해서 고수분의 도움을 받았고 나머지는 제가 구현을 했습니다.

고수분이 알려주신 로직은 함수로 만들어서 깔금하게 처리했더군요. 전 그냥 기본 수준으로 처리했습니다.

엑셀의 행높이와 열너비를 구해서 파일로 저장하는 VBA 코드입니다.

첨부된 파일은 아래 코드입니다. 다운로드 받아서 텍스트 에디터로 열어서 복사하여 붙여넣기 하면 됩니다.

VBA 실행방법을 잘 모르시는 분은 http://link2me.tistory.com/565 참조해서 따라하면 금방 이해될 겁니다.

Row_Height_vba.vbs

Sub Save_RowHeight()

    Dim i%, Col As Variant, Ro As Variant

    ReDim Ro(1 To 30)

    For i = 1 To 30   '// 행의 개수는 필요한 경우 수정해줌

        Ro(i) = Cells(i, 1).RowHeight

    Next i

    Open ThisWorkbook.Path & "\ro.css" For Output As #1

    Print #1, Join(Ro, ",")

    Close #1  '// 작업을 마치고 파일을 닫는다

    ReDim Col(1 To Columns("Y").Column)

    For i = 1 To Columns("Y").Column

        Col(i) = Cells(1, i).ColumnWidth

    Next i

    Open ThisWorkbook.Path & "\col.css" For Output As #2

    Print #2, Join(Col, ",")

    Close #2   '// 작업을 마치고 파일을 닫는다

End Sub

저장된 파일에서 읽어서 행높이와 열너비를 자동으로 지정하는 VBA 코드입니다.

행높이와 열너비라서 저장된 파일이 한줄이라서 파일 여러줄을 읽을 필요가 없는 경우입니다.

그래서 줄의 마지막까지 데이터를 읽어서 처리하는 형태가 아님

Sub Get_RowHeight()

    Dim strTemp As String

    Dim varTemp As Variant

    Dim i, j As Integer

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

    Open ThisWorkbook.Path & "\ro.css" For Input As #1

    Line Input #1, strTemp

    varTemp = Split(strTemp, ",")

    For i = 0 To UBound(varTemp)

        Cells(i + 1, 1).RowHeight = Val(varTemp(i))

    Next i

    Close #1 '// 파일번호 닫기

    Open ThisWorkbook.Path & "\col.css" For Input As #2

    Line Input #2, strTemp

    varTemp = Split(strTemp, ",")

    For j = 0 To UBound(varTemp)

        Cells(1, j + 1).ColumnWidth = Val(varTemp(j))

    Next j

    Close #2 '// 파일번호 닫기

End Sub

엑셀내 모든 이미지 지우는 VBA

테이블 구조 설계를 하면서 코딩 작업을 하면서 테이블 구조를 수시로 참조하면서 작업을 해야 하는데 좀 불편해서 편하게 할 방법이 없나 고민하다가 phpMyAdmin 에서 테이블 구조를 Drag & Drop 으로 복사하여 엑셀에 붙여넣기를 했더니....

이런식으로 그림 이미지가 잔뜩 붙어있습니다.

이 이미지를 제거하는 VBA 코드 입니다.

Sub Delete_Shape()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        Shp.Delete
    Next Shp
End Sub

실행하고 나면 이미지가 모두 제거 됩니다.

간단하지만 필요에 따라 유용하게 사용할 수 있습니다.

인터넷에서 자료를 검색하다가 보면 자료가 콤마(,)로 부분되어 있고 이걸 가져와서 셀에 붙여넣기를 하면 한 셀에 데이터가 저장되는 경우가 있습니다.

자료를 분리한 다음에 특정 열기준으로 하단으로 자료를 죽 쌓고 싶은 경우에 사용하는 VBA Code 입니다.

셀분리정렬.xlsm

Sub Cell_Split_and_Column_Save()

    Dim rngC As Range

    Dim rnaAll As Range

    Dim varTemp As Variant

    Dim i, n As Integer

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

    rngCh = "A"                          '// 열지정

    StartRow = 2                      '// 데이터 시작행 설정

    Set rngAll = Range(Cells(StartRow, rngCh), Cells(Rows.Count, rngCh).End(3))  '// 범위지정

    For Each rngC In rngAll

        varTemp = Split(rngC, ",")

        For i = LBound(varTemp) To UBound(varTemp)  '// 배열 하한값에서 상한값까지 반복

                Cells(Rows.Count, "B").End(3)(2) = Trim(varTemp(i))  '// 분리한 문자를 셀에 입력

                n = n + 1

        Next i

    Next rngC

    Set rngAll = Nothing

    MsgBox "총 " & n & "개 완료"

End Sub

중복개수 표시 VBA

중복개수가 3이면 전부 3으로 표시하고 싶을 때 사용하는 VBA 코드 입니다.

중복개수를 구할 때는 가급적이면 중복개수 구할 필드를 Sorting(정렬) 해두면 빠릅니다.

엑셀에서 기본 제공하는 CountIF 함수를 VBA 에서 이용하고자 한다면 Applicaton.CountIF 처럼 앞에 Application 을 붙여주면 됩니다.

내가 잘 알고 있는 엑셀함수를 이용하고자 할 때에는 이렇게 사용하면 됩니다.

엑셀로 작업을 하다보면 중복개수를 전부다 표시를 해두면 유용한 경우가 있고, 중복을 카운트로 증가시키면 유용한 경우가 있습니다.

그런데 이 함수는 엑셀에서도 범위지정이 크면 메모리 에러가 발생하고, VBA 에서도 심한 지연현상이 발생하더군요. 제가 테스트한 범위는 30만개 데이터였습니다. 

Sub 중복개수표시()

    Dim rngC As Range

    Dim rngAll As Range

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

    rngCh = "A"                          '// 열지정

    StartRow = 2                      '// 데이터 시작행 설정

    Set rngAll = Range(Cells(StartRow, rngCh), Cells(Rows.Count, rngCh).End(3))  '// 범위지정

    For Each rngC In rngAll

        rngC.Offset(0, 1) = Application.CountIf(rngAll, rngC)

        '// 동일한 경우만큼 모두 숫자를 표시

    Next rngC

    Set rngAll = Nothing

    MsgBox "완료"

End Sub

먼저 Sorting 을 한다음에 데이터를 좀 잘게 잘라서 for 문으로 돌려가면서 처리하는게 방법이지 않을까 싶더군요. 그래서 중복개수 표시수를 증가하면서 표시되게 하는 VBA 코드를 만들어봤습니다.

SplitLine 은 500 정도될 때 속도가 가장 빠르던데 PC 환경마다 조금씩 다를 거라 봅니다.

고수분께서 잘못된 것이 있으면 지적해주시면 감사하겠구요.

Sub 중복개수표시()

    Dim rngDB As Range

    Dim i, n As Double

    Dim SplitLine, startRow, LastRow As Double  '// Integer 로 지정하면 버퍼오버플로우가 날 수 있다.

    startRow = InputBox("시작행을 입력하세요")

    If startRow = "" Then Exit Sub              '// 입력값이 없으면 매크로 중단

    If Not IsNumeric(startRow) Then Exit Sub     '// 숫자가 아니면 매크로 중단

    SplitLine = 3000

    For n = 1 To (Cells(Rows.Count, "D").End(3).Row \ SplitLine) + 1

        If (SplitLine + startRow) > Cells(Rows.Count, "D").End(3).Row Then

            LastRow = Cells(Rows.Count, "D").End(3).Row     '// 마지막 행이 SplitLine 보다 작으면

        Else

            LastRow = SplitLine + startRow                  '// 마지막 행이 SplitLine 보다 크면

        End If

        Set rngDB = Range(Cells(startRow, "D"), Cells(LastRow, "D"))

        For i = startRow To LastRow     '// SplitLine 만큼 반복 수행하라

            Cells(i, "E") = Application.CountIf(rngDB, Cells(i, "D"))

        Next i

        Cells(i - 1, "Q") = 1  '// for 문 종료 다음 셀을 찾기 쉽게 반복된 구간마다 1을 마킹하라

        Set rngDB = Nothing    '// 메모리 비우기 

        Do Until (Cells(i, "D") <> Cells(i - 1, "D"))   '// 조건이 충족될 때까지 처리를 반복하라

            i = i - 1

        Loop            '// 조건이 충족되면 Loop 다음으로 이동하라

        startRow = i    '// Do Until 문으로 셀이 서로 다른 행까지 찾은 값을 시작행으로 지정

       If Cells(Rows.Count, "D").End(3).Row <= LastRow Then Exit For    '// LastRow 보다 작으면 For 문을 종료

        'Application.Wait Now() + TimeValue("00:00:02")  '// 메모리 비우는 작업을 수행??

    Next n

    MsgBox "완료"

End Sub

약간씩 타이머로 대기를 하는 경우에도 약간 더 시간이 걸리기는 하지만 결과는 잘 나오더군요.

        Do Until (Cells(i, "D") <> Cells(i - 1, "D"))   '// 조건이 충족될 때까지 처리를 반복하라

            i = i - 1

        Loop            '// 조건이 충족되면 Loop 다음으로 이동하라

주소에서 지역만 다시 정리

주소에 지역명이 제각각 나오는 경우가 있습니다.

이럴 경우 지역명을 2자리로 지정하는 VBA Code 입니다.

Sub 주소지역정리()
    Dim rngDB As Range
   
    With Sheets("addr_data")
        Set rngDB = .Range(.Cells(2, "E"), .Cells(Rows.Count, "E").End(3))  '// 주소가 들어있는 열 지정
        rngDB.Replace "경기도", "경기", xlPart
        rngDB.Replace "강원도", "강원", xlPart
        rngDB.Replace "경상북도", "경북", xlPart
        rngDB.Replace "경상남도", "경남", xlPart
        rngDB.Replace "충청북도", "충북", xlPart
        rngDB.Replace "충청남도", "충남", xlPart
        rngDB.Replace "전라북도", "전북", xlPart
        rngDB.Replace "전라남도", "전남", xlPart
        rngDB.Replace "제주도", "제주", xlPart
        rngDB.Replace "인천광역시", "인천", xlPart
        rngDB.Replace "대전광역시", "대전", xlPart
        rngDB.Replace "부산광역시", "부산", xlPart
        rngDB.Replace "대구광역시", "대구", xlPart
        rngDB.Replace "인천광역시", "인천", xlPart
        rngDB.Replace "울산광역시", "울산", xlPart
        rngDB.Replace "서울특별시", "서울", xlPart
        rngDB.Replace "세종특별자치시", "세종", xlPart
    End With
    MsgBox "주소지역 정리완료"
End Sub

주소 지역명 자동추출 VBA

엑셀을 다루다보면 주소를 정리해야 할 때가 있습니다.

주소에 나온 지역명을 2자리만 자동으로 추출하고 싶은 경우 아래 VBA 코드를 사용하면 금방 추출이 가능합니다.

시작하는 열과 시작행을 써주기만 하면 알아서 자동으로 우축에 지역명을 추출해 줍니다.

지역명추출.vbs

Sub 지역명추출()
    Dim rngC As Range       '// 각 Line 변수
    Dim rngAll As Range     '// 전체 범위 지정
    Dim rngCh
    Dim StartRow As Integer

    Application.ScreenUpdating = False   '// 화면 업데이트 (일시) 중지
    rngCh = "D"                          '// 열지정
    StartRow = 3                      '// 데이터 시작행 설정
    Set rngAll = Range(Cells(StartRow, rngCh), Cells(Rows.Count, rngCh).End(3))  '// 범위지정

    If Cells(StartRow - 1, rngCh).Offset(0, 1) <> "지역" Then
        Cells(StartRow - 1, rngCh).Offset(0, 1).EntireColumn.Insert
        Cells(StartRow - 1, rngCh).Offset(0, 1) = "지역"
        Cells(StartRow - 1, rngCh).Offset(0, 1).ColumnWidth = 6    '// 열너비 설정
    End If

    For Each rngC In rngAll
        Select Case Left(rngC, 2)
            Case "충청"
                If Left(rngC, 4) = "충청북도" Then
                    rngC.Offset(0, 1) = "충북"
                Else
                    rngC.Offset(0, 1) = "충남"
                End If
            Case "전라"
                If Left(rngC, 4) = "전라북도" Then
                    rngC.Offset(0, 1) = "전북"
                Else
                    rngC.Offset(0, 1) = "전남"
                End If
            Case "경상"
                If Left(rngC, 4) = "경상북도" Then
                    rngC.Offset(0, 1) = "경북"
                Else
                    rngC.Offset(0, 1) = "경남"
                End If
            Case Else
                rngC.Offset(0, 1) = Left(rngC, 2)
        End Select
    Next rngC
   
    rngAll.Offset(0, 1).HorizontalAlignment = xlCenter     '// 지역명 열 가운데 정렬
   
    Set rngAll = Nothing  '// 변수 초기화 (메모리 할당 해제)
    MsgBox "완료"
End Sub

SRT 자막파일을 엑셀 VBA 로 편집

SRT 자막파일의 구조를 보면 이렇게 생겼다.

번호와 바로 아래 타임코드(timecode) 정보가 있다.

그리고 그 아래에 자막내용이 있다.

동영상 플레이어에서는 이 타임코드 정보를 기준으로 해서 자막을 화면에 뿌려주게 된다.

자막파일을 가지고 이런 타임코드 정보는 전부다 지우고 자막내용만 남기고 싶은 경우의 VBA 코드를 만들어봤다. 아래코드처럼 한 이유는 자막 내용에 숫자만 들어간 경우가 있을 수 있다.

자막 내용은 지우지 않고 순수하게 타임코드 위의 번호(숫자)만 지우는 걸 고려해서 코드를 만들어봤다.

Sub Sub_Editing()
    Dim rngAll As Range
    Dim i As Integer

    Application.ScreenUpdating = False    '// 화면 업데이트 (일시) 중지
    Set rngAll = Range([A1], Cells(Rows.Count, "A").End(3))

    For i = rngAll.Cells.Count To 1 Step -1     '// 맨 마지막 줄부터 시작해서 거꾸로 i 값을 줄여나가라
        If InStr(Cells(i, 1), ":") And InStr(Cells(i, 1), "-->") Then   '// 타임코드 정보가 포함되어 있다면
            If IsNumeric(Cells(i - 1, 1)) Then                                   '// 타임코드 정보 윗줄이 숫자라면
                Range(Cells(i, 1), Cells(i - 1, 1)).EntireRow.Delete    '// 두줄을 지워라
            End If
            i = i - 1                                                      '// 두줄을 지웠으니 i 값을 하나더 빼라
        ElseIf Trim(Cells(i, 1)) = "" Then
            Cells(i, 1).EntireRow.Delete
        End If
    Next i
   
    Cells(1, 1).Select
    MsgBox "자막정리완료"
End Sub

엑셀과 MySQL 연동처리

엑셀과 MySQL 연동처리를 하기 위한 기초 설명은 http://link2me.tistory.com/421 참조하면 됩니다.

기본적인 환경설정을 위한 정보는 다 설정되었다고 가정하고 추가적인 걸 설명하겠습니다.

MySQL DB 설정에서 DB.Table 을 % 권한을 부여하면 외부 엑셀에서 접속이 가능합니다.

변수선언, DB연결, DB open 하고 테이블의 Column 가져다가 엑셀에서 작업, DB close 하는 순서로 코드가 작성됩니다. 아래 코드는 개념적인 이해를 돕는데 사용하려고 인터넷 자료를 이것 저것 참조하고 짜집기를 좀 한 것입니다. SQL 을 다루는 것이므로 SQL 에 대한 공부가 좀 선행되어야 합니다.

엑셀 Cell 에 있는 값을 조건으로 SQL 문의 WHERE 조건을 걸 때 변수를 어떻게 입력하는지 아셔야 연동하여 원하는 작업을 할 수 있습니다.

저는 MySQL 과 연동하여 MySQL 이라고 했지만 다른 DB와도 연동이 되며, 엑세스와도 연동이 가능합니다.

Sub getMySQLData()

    Dim DBconn As ADODB.Connection

    Dim dbRecset As ADODB.Recordset

    Dim sSQL As String

    Dim iRow As Long, n As Long

    Set DBconn = New ADODB.Connection

    DBconn.ConnectionString = "DRIVER={MySQL ODBC 5.1 Driver};" & _

                            "SERVER=localhost;" & _

                            "PORT=3306" & _

                            "DATABASE=test;" & _

                            "UID=testname;PASSWORD=testpasswd;OPTION=3"   

    DBconn.Open  '// 실제 DB 접속

'// 테이블에서 가져온 데이터의 조건을 걸어서 검사하고 싶다면 For Each 문을 여기에 설정

    '// 테이블에서 가져올 Column 을 SELECT 한다. 

    sSQL = "SELECT * FROM tblName Where 조건"     

    '// Create a recordset and set the CursorLocation property for record navigation

    Set dbRecset = New ADODB.Recordset

    dbRecset.CursorLocation = adUseClient

    '// MySQL DB 데이터 가져오기

    dbRecset.Open Source:=sSQL, ActiveConnection:=conn, CursorType:=adOpenForwardOnly, _

                  LockType:=adLockReadOnly, Options:=adCmdText

   dbRecset.MoveFirst   '// MySQL 가져온 데이터의 첫번째 열로 이동하라

    '//  첫번째 열의 값을 Cells 에 저장하라 

    For n = 1 To dbRecset.Fields.Count 

        Worksheets(1).Cells(1, n).Value = dbRecset.Fields(n - 1).Name 

    Next n

    '// MySQL에서 가져온 데이터를 엑셀 시트에 저장 

    For iRow = 1 To dbRecset.RecordCount   '// Record(행) 수

        For n = 1 To dbRecset.Fields.Count   '// Fields(열) 수

            Worksheets(1).Cells(iRow + 1, n) = dbRecset.Fields(n - 1)

         Next n

         dbRecset.MoveNext

     Next iRow

'// For Each 문의 Next rngC

'//  접속 종료

    dbRecset.Close

    DBconn.Close

    Set dbRecset = Nothing

    Set DBconn = Nothing 

End Sub

Where 조건을 줄 때 어떻게 하는지 한번 살펴보자.

엑셀 셀의 변수를 어떻게 주었는지 주의해서 보셔야 합니다.

strSQL = "select 전화번호 from DB테이블명 "
strSQL = strSQL & "WHERE RIGHT(전화번호,4)='" & myTel & "' "
strSQL = strSQL & "ORDER BY RIGHT(전화번호,4) "

strSQL = "SELECT 품명, SUM(수량) AS 수량합  "
strSQL = strSQL & "FROM DB테이블명 "
strSQL = strSQL & "WHERE 입고일>='" & dStart & "' AND  입고일<='" & dEnd & "'  "
strSQL = strSQL & "GROUP BY  품명 "

sSQL = "INSERT INTO `info` VALUES (" & i & ",'" & Text1.Text & "','" & Text2.Text & "');"

홀수행 또는 짝수행만 추출하는 VBA

홀수행 또는 짝수행만 추출해서 데이터를 추출하고 싶을 때가 있습니다.

이럴 때는 추출하고자 하는 열이 A열이라고 할 때, B열에 번호 순번을 주고 B열을 기준으로 홀짝을 판별하여 A열의 값을 C열에 추출하는 것입니다.

Cells(Rows.Count, "C").End(3)(2) 의 의미는 데이터가 있는 값의 아래에다가 계속 쌓아라 라는 의미입니다.

그러므로 C열에 마지막 셀을 인식할 수 있도록 값을 하나 넣어주면 그 다음셀부터 값을 저장할 것입니다.

Sub 홀수행추출()
    Dim rngC As Range
    Dim rngAll As Range
   
    Application.ScreenUpdating = False      '// 화면 업데이트 (일시)정지
    Set rngAll = Range([b2], Cells(Rows.Count, "b").End(3))
   
    For Each rngC In rngAll
        If rngC Mod 2 = 1 Then
            rngC.Offset(, -1).Copy Cells(Rows.Count, "C").End(3)(2)
        End If
    Next rngC
    Set rngAll = Nothing  '// 변수 초기화
    MsgBox "작업완료"
End Sub

셀을 분리하고 검사를 한 다음에 값을 저장하는 VBA

셀을 분리하여 검사하고 나서 치환한 다음 다시 합치는 결과를 도출해야 할 일이 있어서 만들어 본 VBA 입니다.

VLOOKUP 을 사용하면 결과를 빠르게 돌려주기 때문에 VBA 함수를 호출해서 결과를 얻었습니다.

Sub 셀분리검사저장()

    Dim rngC As Range

    Dim rngAll As Range

    Dim i As Integer

    Dim varTemp

    Dim deLimiter, sTxt As String

    Dim table_array As Range

    Dim table_array2 As Range

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

    deLimiter = " "     '// 구분자

    Set table_array = Sheets("DB").Range("A2:B23542")   '// VLookup 테이블

    Set table_array2 = Sheets("DB").Range("B2:B23542")   '// VLookup 테이블

    For Each rngC In rngAll

        varTemp = Split(rngC, deLimiter)  '// 구분자로 셀을 분리하여 varTemp 배열에 저장

        For i = LBound(varTemp) To UBound(varTemp) - 1   '// 배열의 가장 작은 숫자와 가장 큰 숫자를 추출

            '// i = 0 부터 시작

            sTxt = sTxt & varTemp(i) & deLimiter   '// For 문에서 지정된 것만큼 셀을 합쳐서 하나의 sTxt  로 만듬

        Next i

        sTxt = Trim(sTxt)

        If Len(sTxt) Then

            If Not IsError(Application.VLookup(sTxt, table_array2, 1, 0)) Then   '// 정상적이면

                sTxt = sTxt

            Else

                If IsError(Application.VLookup(sTxt, table_array, 2, 0)) Then

                    sTxt = "[Err] " & sTxt

                Else

                    sTxt = Application.VLookup(sTxt, table_array, 2, 0)  '//서로 일치하는게 있으면 table_array 의 두번째 열의 값을 sTxt에 저장하라

                End If

            End If

            rngC = sTxt & " " & varTemp(UBound(varTemp))

        End If

        sTxt = vbNullString     '// 값을 초기화

    Next rngC

    Set rngAll = Nothing

    Set table_array = Nothing

    Set table_array2 = Nothing

    MsgBox "검사완료"

End Sub

우편번호 주소 정리

전국 우편번호 자료를 구할 수 있는 곳은 우정사업본부 사이트에 가면 있습니다.

우정사업본부 URL : http://www.koreapost.go.kr/kpost/sub/subpage.jsp?contId=010101040300

엑셀로 된 자료를 받아서 원하는 자료를 만들기 위해서 작업을 해봤습니다.

시도 / 시군구 / 읍면동 / 리

로 나눠진 걸 가지고 F열처럼 작업을 했습니다.

rngC.Offset(0, i)의 의미만 알면 아래 VBA Code 이해는 쉽게 됩니다.

rngC.Offset(0, i) 에서 Offset(행,열) 이라고 이해하면 됩니다.

rngC 순환 반복하는 셀에서 rngC.Offset(0,0)은 A열의 셀, rngC.Offset(0,1)은 오른쪽으로 한열 이동한 셀이므로 B열, rngC.Offset(0,2)는 C열, rngC.Offset(0,3)은 D열 입니다.

처음 sTxt 에는 값이 없고, For 문을 순환하면서 값이 변수에 저장됩니다.

Sub 주소정리()
    Dim rngC As Range
    Dim rngAll As Range
    Dim sTxt As String
    Dim deLimiter As String
    Dim i As Integer
           
    Application.ScreenUpdating = False  '//화면 업데이트 일시 정지

    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))   
    deLimiter = " "     '// 구분자
    For Each rngC In rngAll      '// 각 행을 순차적으로 반복 수행
        For i = 0 To 3  '// A열부터 D열까지 반복
            sTxt = sTxt & rngC.Offset(0, i) & deLimiter
        Next i
        rngC.Offset(0, 5) = Trim(sTxt)  '// 한행 작업의 결과를 셀에 저장
        sTxt = vbNullString     '// 한 행의 작업이 끝났으므로 값을 초기화
    Next rngC
    Set rngAll = Nothing     '// 변수 초기화   
End Sub

이번에는 변환주소를 가지고 아래 형태로 자료를 추출하려면 어떻게 해야 할까요?

Split 함수를 이용하여 B열의 셀을 배열로 분리하고, 배열 값을 가지고 아래 코드처럼 변환해줍니다.

varTemp 라는 배열은 varTemp(0), varTemp(1), varTemp(2) 이런 식의 값으로 분리됩니다.

배열의 크기가 달라질 수 있으므로 UBound(varTemp) 를 사용하여 가변 변수 최대숫자를 구합니다.

변수에 맞게 Left 함수를 이용하여 sTxt 값을 만들어내고, 원하는 셀에 저장합니다.

Sub 주소변경()
    Dim rngC As Range
    Dim rngAll As Range
    Dim sTxt As String
    Dim deLimiter As String
    Dim varTemp
    Dim i As Integer
           
    Application.ScreenUpdating = False  '//화면 업데이트 일시 정지
    Set rngAll = Range([B2], Cells(Rows.Count, "B").End(3))
    deLimiter = " "      '// 구분자   
    For Each rngC In rngAll     '// 각 행을 순차적으로 반복 수행
        varTemp = Split(rngC, deLimiter)    '// 구분자로 셀을 분리하여 배열에 저장
        For i = 1 To UBound(varTemp)
            sTxt = sTxt & Left(varTemp(i), Len(varTemp(i)) - 1) & deLimiter
        Next i
        rngC.Offset(0, -1) = varTemp(0) & deLimiter & Trim(sTxt)
        sTxt = vbNullString    '// 한 행의 작업이 끝났으므로 값을 초기화
    Next rngC
    Set rngAll = Nothing    '// 변수 초기화
End Sub

찾고자 하는 단어 전부 찾는 VBA

엑셀을 다루다보면 셀에 포함된 단어를 찾아야 할 경우가 있습니다.

FindVBA.vbs

Sub Character_Find()

    Dim rngC As Range

    Dim rngAll As Range '//대상 범위 지정변수

    Dim FindText As String

    Dim strAddr As String

    Dim S As Integer

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

    'Set rngAll = ActiveSheet.UsedRange

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

    '// End(3) 은 End(xlUp), 데이터가 있는 마지막행까지 자동으로 찾음

    FindText = InputBox("검색할 문자 입력") '//검색할 문자를 변수에 넣음

    If FindText = "" Then Exit Sub           '// 취소 선택시 매크로 중단

    Range([F3], Cells(Rows.Count, "F").End(3)).ClearContents  '// 찾는 값을 기록한 열을 초기화

    With rngAll

        .Font.Bold = False

        .Font.ColorIndex = xlAutomatic

        Set rngC = .Find(what:=FindText, lookat:=xlPart)

        If Not rngC Is Nothing Then

            strAddr = rngC.Address '// 찾은 셀의 주소를 변수에 넣음

            Do

                S = 1

                Do

                    With rngC.Characters(Start:=InStr(S, rngC, FindText), Length:=Len(FindText)).Font

                    '.Bold = True   '// 굵은 글씨로 표시하고 싶으면

                    .Color = vbBlue '// 글자색 표시, vbGreen 녹색 vbRed 빨간색

                    End With

                    rngC.Offset(0, 3) = FindText

                    S = InStr(S, rngC, FindText) + Len(FindText)

                Loop While InStr(S, rngC, FindText)

                Set rngC = .FindNext(rngC) '// 다음 찾은 데이터를 변수에

            Loop While Not rngC Is Nothing And strAddr <> rngC.Address

            '// 검색 일치하지 않거나 처음 찾은 셀이 아닐때까지 무한 반복

        End If

    End With

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

End Sub

셀 분리 활용

데이터가 하나의 셀로 되어 있어서 두개로 분리를 해야 할 경우가 있습니다.

아래 VBA 코드를 가지고 msgbox Ubound(varTemp) 도 넣어서 F8 키를 눌러서 확인 등을 해보면 확실하게 알 수 있습니다.

하나하나 분리해야 할 때에는 For i Next 구문 대신에 rngC.Next.Resize(1,Ubound(varTemp)) = varTemp 를 넣어주면 됩니다. 

Sub 셀분리()

    Dim rngC As Range

    Dim rngAll As Range

    Dim i As Integer

    Dim varTemp

    Dim deLimiter, sTxt As String

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

    deLimiter = " "     '// 구분자

    For Each rngC In rngAll

        varTemp = Split(rngC, deLimiter)  '// 구분자로 셀을 분리하여 varTemp 배열에 저장

        For i = LBound(varTemp) To UBound(varTemp) - 1   '// 배열의 가장 작은 숫자와 가장 큰 숫자를 추출

            '// i = 0 부터 시작

            sTxt = sTxt & varTemp(i) & deLimiter   '// For 문에서 지정된 것만큼 셀을 합쳐서 하나의 sTxt  로 만듬

        Next i

        rngC.Next = sTxt    '// 현재 셀 오른쪽에 sTxt 를 저장

        rngC.Offset(0, 2) = varTemp(UBound(varTemp))   '// 마지막 부분을 현재셀 오른쪽 2번째 셀에 기록

        sTxt = vbNullString     '// 값을 초기화

    Next rngC

End Sub

폴더와 하위 폴더에 있는 파일명들을 텍스트로 추출하기

폴더에 자료가 너무 많아서 원하는 자료를 결과작업을 하기가 힘든 경우가 있습니다.

이런 경우에는 기본적인 DOS 명령어를 활용하고 엑셀을 이용해서 편집하면 편합니다.

원하는 폴더로 이동하기 편하게 하는 가장 좋은 방법으로 Total Commander 를 사용합니다.

토탈커맨더는 파일 작업하는데 편하고 좋은 기능 들이 엄청 많이 있습니다.

dir 기본적이 명령어를 알고 싶다면 dir /? 로 확인하면 됩니다.

파일이 저장된 것을 확인할 수 있습니다.

dir /w/s >fileName.txt
dir /s/b >fileName.txt
dir *.mp3 /w/s >fileName.txt

/s는 서브디렉토리(폴더)까지 검색하는 옵션
/b는 파일사이즈, 날짜 등을 표시하지 않고 간단히 보여주는 옵션
/d는 한줄로 저장하고 싶을 때
/w는 한줄에 여러개의 파일을 동시에 저장하고 싶을 때
*.mp3 는 mp3 파일만 서브디렉토리까지 전부 추출

이렇게 저장된 파일을 엑셀VBA 를 이용하여 읽어들여서 편집하여 원하는 결과를 찾아낼 수가 있습니다.

.

텍스트파일을 엑셀로 읽어서 정렬

엑셀 VBA 에서 텍스트 파일을 읽어들여서 셀을 나눠서 작업하기 위한 용도의 VBA Code.

현재 자료 하단에 자료를 추가하고 싶다면

    ActiveSheet.UsedRange.Clear 를 주석처리하고

    iRow = Cells(Rows.Count, "A").End(3).(2).Row 

라고 해주면 마지막 셀 하단에 자료가 추가가 됩니다.

구분자로 분리하고 싶지 않다면

        varTemp = Split(openTxt, ";")   '// 구분자로 읽어들인 하나의 행을 나눠서 배열에 저장
        Cells(iRow, 1).Resize(, UBound(varTemp) + 1) = varTemp '// 읽은 1행을, 엑셀 셀에 입력

대신에 Cells(iRow, 1).Value = openTxt '// 읽은 1행을, 엑셀 셀에 입력

Sub TextFile_To_ExcelRead()
    Dim openTxt As String
    Dim fileName As String
    Dim varTemp As Variant     
    Dim fileHandle As Integer
    Dim iRow As Long

    fileName = Application.GetOpenFilename("Text Files(*.txt),*.txt, Add-in Files (*.csv), *.csv", , "Please select text file...")
    If fileName = "False" Then     '//취소 선택 시 매크로 종료

        MsgBox "취소버튼이 선택되었습니다"   
        Exit Sub
    End If

    ActiveSheet.UsedRange.Clear   '// 현재 활성화된 시트에 있는 기존 데이터 전부 삭제

    iRow = 1     '// 활성화된 시트데이터를 지우지 않고 아래에 추가하고 싶다면 ??

    Application.ScreenUpdating = False  '// 화면 업데이트 일시 정지
    fileHandle = FreeFile   '// 사용 가능한, 파일 핸들 번호 구하기
    Open fileName For Input As fileHandle    '// 파일 열기

    '// 텍스트 파일 한 줄씩 읽기 (한글 영문 모두 가능)
    Do While Not EOF(fileHandle)    '// 파일의 끝까지 반복
        Line Input #fileHandle, openTxt  '// 읽은 1줄을 변수 openTxt 에 대입
        '// Line Input#문은 열려 있는 순차 파일에서 하나의 행을 읽어서 String 변수에 저장
        varTemp = Split(openTxt, ";")   '// 구분자로 읽어들인 하나의 행을 나눠서 배열에 저장
        Cells(iRow, 1).Resize(, UBound(varTemp) + 1) = varTemp '// 읽은 1행을, 엑셀 셀에 입력
        iRow = iRow + 1        '// 다음 행에 입력하기 위해 행번호 증가
    Loop

    Close fileHandle    '// 위에서 연 파일 닫기
   
    Range("C1").Select
    Selection.AutoFilter    '// 첫줄 자동필터, 만약 필터가 적용되었다면 해제가 됨
    Columns("A:B").HorizontalAlignment = xlCenter  '// A열,B열 가운데 정렬
    Rows(1).HorizontalAlignment = xlCenter  '// 1행만 가운데 정렬
    Columns.AutoFit     '// 열너비 자동 맞춤

End Sub

내보내고 싶은 열만 텍스트 파일로 내보내기

작업을 하다보면 특정한 열만 내보내고 싶은 경우가 있습니다.

이럴 경우 아래 주황색으로 된 부분처럼 해주면 됩니다.

1. 행은 2행부터 자료가 있는 마지막 열까지

2. 열은 1열부터 7열까지, 즉 A열부터 G열까지

3. 실제 내보내기할 열은 A열, F열, G열

Sub TextExport()
'// 내보내고 싶은 열만 선택해서 텍스트 파일로 내보내기
    Dim iRow As Long, iCol As Integer
    Dim sTxt As String, fPath As String
    Dim FN As Integer

    FN = FreeFile
    fPath = ThisWorkbook.Path & "\update_data.csv"

    deLimiter = ";"     '// 구분자
    Open fPath For Output As #FN
        For iRow = 2 To Cells(Rows.Count, "E").End(3).Row   '// 행지정
            sTxt = vbNullString
            For iCol = 1 To 7   '// 열 지정
                If Cells(iRow, 7) = 1 Then
                    If (iCol = 1) Or (iCol = 6) Or (iCol = 7) Then
                        sTxt = sTxt & Cells(iRow, iCol) & deLimiter
                    End If
                End If
            Next iCol
            If Len(sTxt) Then Print #FN, Left(sTxt, Len(sTxt) - 1)
        Next iRow
    Close #FN   '// 작업을 마치고 파일을 닫는다
    MsgBox "내보내기 완료"
End Sub

현 시트내용을 서식 포함 여러개 파일로 분할 저장

열너비 및 서식까지 그대로 복사하면서 파일을 분할하여 내보내기하는 VBA 코드

Sub split_As_per_Rows()
    '// 지정한 행만큼씩 파일을 나눠서 저장하는 VBA
    Dim Counter As String
    Dim rngAll As Range                           '//모든 영역을 저장할 변수
    Dim SplitLine As Integer                      '//몇 행씩 나눌지를 정하는 변수
    Dim rowsCount As Long, colsCount As Integer   '//행 및 열의 갯수 저장할 변수
    Dim strPath As String                         '//파일저장 경로를 넣을 변수
    Dim i As Long                                 '//반복구문 숫자 증가에 사용할 변수
    Dim rngSplit As Range                         '//나누어진 영역을 저장할 변수
    Dim strName As String
  
    Counter = InputBox("분할할 행의 수 입력하세요")
    If Counter = "" Then Exit Sub           '// 취소 선택시 매크로 중단
    If Not IsNumeric(Counter) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우

    Application.ScreenUpdating = False      '//화면 업데이트 (일시)정지
    Set rngAll = ActiveSheet.UsedRange      '//사용전체영역을 변수에 넣음
    SplitLine = Counter                     '// 입력한 숫자 만큼 파일이 나눠서 저장
    rowsCount = rngAll.Rows.Count           '//전체 행의 숫자를 행 변수에 넣음
    colsCount = rngAll.Columns.Count        '//전체 열의 숫자를 열 변수에 넣음
    strPath = ThisWorkbook.Path & Application.PathSeparator   '//현재 파일이 있는 경로에 저장

    With ThisWorkbook
      strName = Left(.Name, Len(.Name) - 5)  '//Excel 파일의 확장자 제거. 만약 xls 파일이면 숫자를 4로 변경
    End With

    For i = 1 To rowsCount Step SplitLine          '//SplitLine 만큼씩 증가하며 반복
        Set rngSplit = Range(Cells(i + 1, 1), Cells(i + SplitLine, colsCount))   '//나누어진 영역을 변수에 넣음
        Workbooks.Add                                 '//새로운 workbook을 생성
        rngAll.Rows(1).SpecialCells(2).Copy Cells(1, 1)      '//첫줄 제목을 각 workbook에 복사           
        rngSplit.Copy      '//2번째 행부터 SplitLine 만큼 나누어진 영역을 복사        
        With Cells(2, 1)
            .PasteSpecial Paste:=xlPasteColumnWidths  '//열너비 복사
            .PasteSpecial Paste:=xlPasteFormats       '//양식 복사
            .PasteSpecial Paste:=xlPasteValues       '// 값 복사
        End With
       
        Range("E1").Select
        Selection.AutoFilter    '// 첫줄 자동필터 지정
               
        ActiveWorkbook.SaveAs strPath & strName & "(" & ((i - 1) \ SplitLine) + 1 & ").xlsx", FileFormat:=xlOpenXMLWorkbook
                     '//현재 파일이 있는 경로에 현재파일명 + SplitLine 만큼씩 나눠서 몫으로 카운트하면서 저장
        ActiveWorkbook.Close   '//새로 만든 workbook을 저장
    Next i

    Set rngAll = Nothing     '//개체변수들 초기화(사용 메모리 비우기)
    Set rngSplit = Nothing    '//개체변수들 초기화(사용 메모리 비우기)
End Sub

노래가사 파일로 내보내기

노래 가사를 파일로 내보내기를 하고 싶은 경우가 있어서 엑셀 VBA 를 이용하여 내보내기를 해 본 적이 있습니다. 아래 VBA Code 는 지금보다 더 초보시절에 최선을님께서 만들어주신 겁니다.

노래가사 파일형식은 lrc 로 되어 있고요. 내용은 텍스트형식으로 되어 있습니다.

아래 코드에 대해 간략하게 설명을 하자면.....

1. 파일경로가 있는지 검사하고 없다면 파일경로 폴더를 생성하라.

2. 파일로 내보낼 셀을 For Each 문을 이용하여 돌려라.

3. IF문으로 조건을 검사하여 윗셀과 아래셀을 검사하여 서로 같으면 내용을 같은 파일로 저장하고,

   다르면 파일에 저장하라.

4. 파일명을 생성하고 내용을 채워서 저장한다.

    - 파일에 데이터를 쓰기 위해서는 Print # 문을 사용한다.

    - Print #filenumber, output

    - Line Input # 문으로 읽어 온 데이터는 일반적으로 Print #을 사용하여 파일을 저장

Sub LRC내보내기()
    Dim ff As Integer
    Dim rngC As Range
    Dim Data As String
   
    If Len(Dir(ThisWorkbook.Path & "\lrc\", vbDirectory)) = 0 Then
        MkDir ThisWorkbook.Path & "\lrc"     '// 파일경로가 없을 경우 파일경로 생성
    End If
   
    Data = [B2] & " " & [C2]   
    For Each rngC In Range([D3], Cells(Rows.Count, "D").End(3)(2))
        '// D3부터 D열 마지막셀까지 rngC에 할당하라
        '//.End(3)이면 마지막 셀이고, .End(3)(2)이면 마지막 셀 다음 셀
        If rngC.Offset(-1) <> rngC Then
           '// 순환하는 현재셀 rngC가 D3라면 rngC.Offser(-1)은 D2 셀이므로 바로 윗셀과 같지 않으면 이란 의미
            ff = FreeFile
            '// 변수에 파일 번호를 할당           
            Open ThisWorkbook.Path & "\lrc\" & rngC.Offset(-1).Text For Output As #ff  '// 텍스트 파일로 내보냄
            '// 파일을 연다. 파일번호는 #ff
                Print #ff, Data  '// Data의 내용을 텍스트 파일에 입력
            Close #ff  '// 작업을 마치고 파일을 닫는다           
            Data = rngC.Offset(, -2) & " " & rngC.Offset(, -1)
            '// 현재 순환하는 셀의 왼쪽 두번째 셀과 + 공백 + 왼쪽 첫번째 셀값을 변수에 넣음           
        Else
            Data = Data & vbNewLine & rngC.Offset(, -2) & " " & rngC.Offset(, -1)
        End If
    Next   
    MsgBox "완료!!", 64, "최선을"   
End Sub

VBA 중복개수 표시

CountIF 함수를 사용하여 중복된 것만 개수를 표시하는 VBA 코드입니다.

아래 코드를 활용할 경우 초보자는 주황색으로 표시된 부분만 고쳐서 이용하면 됩니다.

하는 방법은 엑셀에서 Alt + F11 키 누르면 나오는 창에서 [삽입] - [모듈] 누르고 나오는 화면에 코드를 복사하여 붙여넣기 하고요. 코드 사이에서 마우스 커서 놓고 F5키 누르면 됩니다.

Sub 중복개수표시()
    Dim rngC, rngT As Range    '// 각 셀을 넣을 변수
    Dim rngAll As Range        '// 전체 데이터 영역을 넣을 변수
    Dim rngVariable As Range  '// 변하는 영역변수
    Dim i As Integer

    Set rngAll = Range([C2], Cells(Rows.Count, "C").End(3))   '// C열 전체를 범위로 지정
    Set rngT = [C2]      '// 위가 [C2] 이면 똑같이 C2 로 지정
    Range([E2], Cells(Rows.Count, "E").End(3)).ClearContents   '// 중복을 표시할 열이 설정된 값 초기화
 
    For Each rngC In rngAll
        Set rngVariable = Range(rngT, rngC)
        '// COUNTIF(범위,조건) : 범위에서 조건에 맞는게 몇개인지 카운트하라
        If Application.CountIf(rngVariable, rngC) <> 1 Then  '// 1인 것은 표시하지 말라
            rngC.Offset(0, 2) = Application.CountIf(rngVariable, rngC)

               '// 중복된 숫자를 표시할 열로서 검사하는 열로부터 오른쪽 2번째 열에 표시하라
            i = i + 1
        End If
    Next rngC
    Set rngAll = Nothing  '// 변수 초기화
    MsgBox "총 " & i & "개 중복발생"
End Sub

이 코드를 이용하여 행의 수가 52000개 되는 우편번호 주소를 편집하여 검색했더니 overflow 가 나온다.

엑셀에서 제공하는 중복제거 함수를 이용했더니 순식간에 중복을 제거하고 결과를 알려준다.

그냥 무작정 이런 코드를 쓰는 것보다, 엑셀의 기본기능을 잘 이용하고 적절한 함수를 쓰는 것이 훨씬 더 빠른 결과를 가져올 수 있다는 걸 알게 되었다.

MySQL 데이터 엑셀로 가져오기

MySQL 데이터를 엑셀로 가져오는 VBA 코드입니다.

코드는 구글링해서 찾은 여러자료를 분석해서 알기 쉽게 다시 정리 했습니다.

Sub GetMysSQLData()
    Dim DBConn As ADODB.Connection
    Dim RS As ADODB.Recordset
    Dim sSQL As String
    Dim dbConnStr As String
    Dim i As Long, dbRow As Long

    Dim DB_host As Variant
    Dim DB_User As Variant
    Dim DB_pass As Variant
    Dim DB_Name As Variant
    
    Application.ScreenUpdating = False  '// 화면 업데이트 정지

    Set shtName = Worksheets("DB_Setting")   '// DB_Setting Sheet 에서 설정한 값을 가져온다
    Set DB_host = shtName.Range("A2")     '// IP  설정 값. 호스팅업체에서 알려준 접속 host URL
    Set DB_port = shtName.Range("B2")   '// PORT  설정 값. MySQL Port 는 3306 포트가 default
    Set DB_User = shtName.Range("C2")   '// User ID 설정 값
    Set DB_pass = shtName.Range("D2")   '// PASSWord  설정 값
    Set DB_Name = shtName.Range("E2")   '// DB명  설정 값

    Set DBConn = New ADODB.Connection
    dbConnStr = "DRIVER={MySQL ODBC 5.1 Driver};SERVER=" & DB_host & ";PORT=" & DB_port & ";DATABASE=" & DB_Name & ";USER=" & DB_User & ";PASSWORD=" & DB_pass & ";OPTION=3;"

    DBConn.Open dbConnStr   '// Open MySQL DB connection
    Set RS = New ADODB.Recordset
    RS.CursorLocation = adUseClient
   
    '// SQL 문 작성
    'sSQL = "SELECT * FROM tblName"
    sSQL = "SELECT uid, name, email, sex FROM tblName"
   
    '// MySQL 데이터 가져오기
    RS.Open Source:=sSQL, ActiveConnection:=DBConn, CursorType:=adOpenDynamic, LockType:=adLockReadOnly, Options:=adCmdText

    RS.MoveFirst  '// Move to the first record
    Worksheets("TEST").Select   '// 다른 시트에 있어도 TEST 시트로 ActiveSheet 가 전환됨
    With Worksheets("TEST") '// Sheet 명을 지정한다
        .Range("A1:AZ1048576").ClearContents    '// 기존 데이터는 전부 삭제
        For i = 1 To RS.Fields.Count        '// MySQL 필드의 제목 가져다 뿌려준다
            .Cells(1, i).Value = RS.Fields(i - 1).Name
        Next i
   
        .Range("A2").CopyFromRecordset RS   '// MySQL 데이터를 A2 열부터 뿌려준다
       
        .Range([A1], Cells(1, RS.Fields.Count)).Select
        Selection.AutoFilter
        Cells(1, 2).Select
        .Columns.AutoFit      '// 전체열 열너비 자동맞춤
    End With
   
    '//Close connection again
    RS.Close
    DBConn.Close
    
    Set RS = Nothing
    Set DBConn = Nothing
End Sub

GetMysSQLData.xlsm

첨부된 샘플파일에 설명이 나와 있으니 수정해서 사용하면 됩니다.