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

부분적으로 일치하는 걸 가져오는 SQLVBA 코드이다.

strSQL = strSQL & "전화번호 LIKE '%" & S & "%' "

와 같이 SQL 에서 사용하는 wildcard 변수를 사용하면 된다.

만약 고급필더 버튼을 이용하여 데이터를 가져오고자 한다면

전화번호에 *3363 이라고 입력하면 해당되는 자료를 가져올 수 있다.

고급필터의 경우에는 반드시 A3열의 값이 비어 있으면 안된다. 아니면 IF조건문을 변경하던지 해야 하는 거 같다.

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 S, T As String
       
    Set sht1 = Sheets("Main")      '// 현재 작업중인 워크시트 명
    Set DBconn = New ADODB.Connection
   
    FilePath = ThisWorkbook.Path + "\"  '// 현재 파일 경로
    FileName = ActiveWorkbook.Name      '// 같은 엑셀파일(현재 엑셀화면에 활성화된 파일)
   
    S = sht1.Range("A3")      '// 전화번호
    T = sht1.Range("B3")      '// 이름
    
    strSQL = "SELECT * FROM [Data$] "           '// 엑셀시트이면 뒤에 $ 를 붙인다. Data Sheet 가 존재해야 한다.
    If S <> vbNullString Or T <> vbNullString Then strSQL = strSQL & "Where "
    If S <> vbNullString Then strSQL = strSQL & "전화번호 LIKE '%" & S & "%' "
    If S <> vbNullString And T <> vbNullString Then strSQL = strSQL & " and"
    If T <> vbNullString Then strSQL = strSQL & " 이름 Like '%" & T & "%' "        '// 텍스트 변수처리
   
    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    '// 현재 존재하는 값을 전부 삭제
        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 ("가져올 자료가 없음")
                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

* 첨부파일은 위의 코드가 포함된 코드입니다. 필요한 분은 받아서 수정사용하세요

getSQL_FileData.xlsm

엑셀에서 내 PC에 있는 특정 폴더의 파일 리스트를 가져올 수 있다.

서브폴더 자료까지 편하게 가져올 수 있기 때문에 여러모로 편리하다.

파일 리스트.xlsm

Option Explicit
Sub getFileList()
'// [도구] - [참조] 에서 Microsoft Scripting Runtime 라이브러리 체크해야 함
    Dim FSO As New FileSystemObject
    Dim sDir As Folder      '// 찾을 폴더 변수 선언
    Dim fPath As Variant    '// 경로(Path) 변수 선언
    Dim fileExt As String   '// 파일확장자 변수 선언
    Dim i, n As Long
    Dim openMsg As String
   
    On Error Resume Next     '// 에러가 발생해도 계속 수행하라
    openMsg = "파일을 가져올 경로를 직접 지정하려면 Yes를 눌러주세요 " & vbCr & vbCr
    openMsg = openMsg & "현재 경로를 선택하려면 No를 눌러주세요" & vbCr
    openMsg = openMsg & "현재 Path : " & ThisWorkbook.Path + "\"
    If MsgBox(openMsg, vbYesNo) = vbYes Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            fPath = .SelectedItems(1)   '// 선택될 폴더를 경로 변수에 저장
        End With
    Else
        fPath = ThisWorkbook.Path + "\"     '// 엑셀 VBA 파일이 위치한 현재경로
    End If
    If Err.Number <> 0 Or fPath = False Then Exit Sub
    On Error GoTo 0
   
    fileExt = "*.mp3"   '// 찾고자 하는 파일 확장자
    Worksheets("검색결과").Select     '// 다른 시트가 선택되어 있어 잘못 기록되는 경우 방지 목적
    With Range("A1:C1")
        .Value = Array("디렉토리", "파일명", "중복검사")
        .HorizontalAlignment = xlCenter
    End With
   
    Range([A1], Cells(Rows.Count, "A").End(3)).Offset(1).Resize(, 3).ClearContents
    '// 화면에 뿌릴 영역 초기화. 이줄을 지우면 검색하여 가져오는 것마다 마지막 자료에 추가됨
   
  
    Call makeFileList(fPath, fileExt)   '// 파일목록 만들기 호출
    Set sDir = FSO.GetFolder(fPath)
    Call subFolderFind(sDir, fileExt)   '// 서브폴더 찾기
   
    n = Cells(Rows.Count, "B").End(3).Row - 1
    If n = 0 Then
        MsgBox "파일이 없습니다"
    Else
        MsgBox n & " 개 파일리스트 검색완료"
    End If
End Sub

Sub subFolderFind(sDir As Folder, getExt As String)
    Dim subFolder As Folder
   
    On Error Resume Next
    For Each subFolder In sDir.SubFolders
        If subFolder.Files.Count > 0 Then
            Call makeFileList(subFolder.Path, getExt)
        End If
           
        If subFolder.SubFolders.Count > 0 Then
            Call subFolderFind(subFolder, getExt)
        End If
    Next
End Sub

Sub makeFileList(fPath As Variant, getExt As String)
    Dim fName As String
    Dim SaveDir As Range
   
    fName = Dir(fPath & "\" & getExt)
    If fName <> "" Then
        Do
            Set SaveDir = Cells(Rows.Count, "A").End(3)(2)
            SaveDir.Value = fPath
            SaveDir.Offset(0, 1).Value = fName
           
            fName = Dir()
        Loop While fName <> ""
        Columns("A:B").AutoFit
    End If
End Sub

이 코드는 VBA 고수이신 "하나를하더라도최선을"님이 만들어주신 코드다.

배열로 담아낼 때 Flag 를 사용한 기법을 나중에 활용할 일이 있을 거 같아서 적어둔다.

코드 설명

IF Not flag Then 라인은 Not flag = true 일 때만 문장이 실행되므로, flag = false 일때만 실행됨

- flag 변수 선언시에는 false 로 되어 있어서 IF문은 참(true)이므로 실행된다.

- Dat(1) 배열에 값을 계속 저장한다. flag=true 이므로 flag IF문은 실행되지 않으므로

- 밑줄 글자가 끝나고 밑줄 아닌 글자가 오면 flag=false 처리하여 false 상태를 유지하다가

- 새로운 밑줄글자를 만나면, Dat(2) 배열에 값을 저장하기 시작한다.

Sub underline_text()
    Dim C, rngAll As Range, Dat As Variant, n%, flag As Boolean, i%
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    For Each C In rngAll
        ReDim Dat(1 To 1): n = 0    '// 배열 및 배열에 사용할 변수 초기화
        For i = 1 To Len(C)
            If C.Characters(Start:=i, Length:=1).Font.Underline = xlUnderlineStyleSingle Then '// 밑줄 글자이면
                If Not flag Then  '// boolean 이 true 일때만 IF문이 실행됨. not flag = true, 즉 flag = false 일때만 실행
                    n = n + 1   '// 사용할 배열의 크기를 1씩 늘려감
                    ReDim Preserve Dat(1 To n)  '// 기존값을 유지하면서 배열크기를 다시 설정
                End If
                Dat(n) = Dat(n) & Mid(C, i, 1)
                flag = True
            Else    '// 밑줄 그어진 글자가 아니면
                flag = False  '// boolean 을 False 로 설정
            End If
        Next i
        C.Offset(, 1) = Join(Dat, " , ")  '// 배열을 ", "로 조인하여 셀에 뿌림
    Next C
End Sub

특정한 파일이 어디에 있는지 찾아내고 싶은 경우가 있다.

FileSearch 기능을  구글링해서 찾아낸 코드와 내가 사용하는 코드를 결합해서 작성을 해보고 있는 중이다.

아직은 For Each rngC in Selection 구문으로 여러파일을 선택했을 경우까지는 해결을 못했다.

ActiveCell 이 위치한 파일의 경로명 가져오는 것은 잘 된다.

조금 더 분석해서 For Each rngC in Selection 구문도 해결을 해보련다.

FileSearch.vbs

** 테스트 해보실 분은 이 파일 받아서 EditPlus 같은 텍스트 에디터로 열어서 VBA 코드에 붙여넣고 수정할 부분 수정해서 실행하시면 됩니다.

Option Explicit
Type FoundFileInfo      '// Properties that will be collected for each found file
    sPath As String
    sName As String
End Type

Sub eachFileSearch()
'// [도구] - [참조] 에서 Microsoft Scripting Runtime 라이브러리 체크해야 함
    Dim FSO As New FileSystemObject
    Dim iFilesNum%, iCount%, r%
    Dim recMyFiles() As FoundFileInfo
    Dim blFilesFound As Boolean
    Dim fPath, sName, openMsg As String    
    Dim rngC, rngAll As Range

    On Error Resume Next     '// 에러가 발생해도 계속 수행하라
    openMsg = "파일을 가져올 경로를 직접 지정하려면 Yes를 눌러주세요 " & vbCr & vbCr
    openMsg = openMsg & "현재 경로를 선택하려면 No를 눌러주세요" & vbCr
    openMsg = openMsg & "현재 Path : " & ThisWorkbook.Path + "\"
    If MsgBox(openMsg, vbYesNoCancel) = vbYes Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = "C:\Excel Basics"
            .Show
            fPath = .SelectedItems(1)   '// 선택될 폴더를 경로 변수에 저장
        End With
    Else
        fPath = ThisWorkbook.Path + "\"     '// 엑셀 VBA 파일이 위치한 현재경로
    End If
    If Err.Number <> 0 Or fPath = False Then Exit Sub
    On Error GoTo 0

    sName = Cells(ActiveCell.Row, "A")
    If sName = "" Then
        MsgBox "파일이 선택되지 않았습니다"
        Exit Sub    '// 실행 종료
    End If
    blFilesFound = FindFiles(fPath, recMyFiles, iFilesNum, sName, True)
    If blFilesFound Then
        For iCount = 1 To iFilesNum
            With recMyFiles(iCount)
                If iCount = 1 Then
                    Cells(ActiveCell.Row, "B") = .sPath
'                        Cells(activecell.row, "C") = .sName
                Else
                    If Len(Cells(ActiveCell.Row, "B")) And InStr(Cells(ActiveCell.Row, "B"), .sPath) = 0 Then
                        Cells(ActiveCell.Row, "B") = Cells(ActiveCell.Row, "B") & vbNewLine & .sPath
                    End If
                End If
            End With
        Next
    Else
        Cells(ActiveCell.Row, "B") = vbNullString     '// 찾는 파일이 없으면 빈공백
    End If
    MsgBox "완료"
End Sub

Function FindFiles(ByVal sPath As String, ByRef recFoundFiles() As FoundFileInfo, _
    ByRef iFilesFound As Integer, _
    Optional ByVal sFileSpec As String = "*.*", _
    Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean

    Dim iCount As Integer           '// Multipurpose counter
    Dim sFileName As String         '// Found file name
    Dim oFileSystem, oParentFolder, oFolder, oFile As Object    '// FileSystem objects

    Set oFileSystem = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set oParentFolder = oFileSystem.GetFolder(sPath)
    If oParentFolder Is Nothing Then
        FindFiles = False
        On Error GoTo 0
        Set oParentFolder = Nothing
        Set oFileSystem = Nothing
        Exit Function
    End If
    sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
    '// Find files
    sFileName = Dir(sPath & sFileSpec, vbNormal)
    If sFileName <> "" Then
        For Each oFile In oParentFolder.Files
            If LCase(oFile.Name) Like LCase(sFileSpec) Then
                iCount = UBound(recFoundFiles)
                iCount = iCount + 1
                ReDim Preserve recFoundFiles(1 To iCount)
                With recFoundFiles(iCount)
                    .sPath = sPath
                    .sName = oFile.Name
                End With
            End If
        Next oFile
        Set oFile = Nothing         '// Although it is nothing
    End If
   
    If blIncludeSubFolders Then     '// sub Folder 를 선택했으면
        For Each oFolder In oParentFolder.SubFolders
            FindFiles oFolder.Path, recFoundFiles, iFilesFound, sFileSpec, blIncludeSubFolders
        Next
    End If
    FindFiles = UBound(recFoundFiles) > 0
    iFilesFound = UBound(recFoundFiles)
    On Error GoTo 0
    '// Clean-up
    Set oFolder = Nothing           '// Although it is nothing
    Set oParentFolder = Nothing
    Set oFileSystem = Nothing
End Function

윈도우 운영체제 기반하의 특정 폴더에서 다른 폴더로 파일을 복사할 때 사용하는 VBA 코드이다.

코드는 파일이 없을 경우, 복사하려는 위치에 파일이 존재할 경우 등이 고려된 코드다.

잘못하여 덮어쓰는 것을 방지할 필요가 있다.

경우에 따라서는 기존 파일을 덮어쓸 필요가 있는 경우도 있을 것이다.

복사에 사용되는 함수는 FSO.CopyFile oldName, newName  이며, 변수선언이 필요하다.

파일복사 명령어가 동일한 VBA.FileCopy oldName, newName 의 경우에는 FSO 변수 선언은 필요없다.

파일복사 명령어는 newPath(복사하려는 폴더) 에 파일 존재해도 복사를 한다.

Sub FSO_CopyFile()  '// 특정 폴더의 파일 복사
    Dim FSO As Object
    Dim rngC, rngAll As Range
    Dim oldName, newName As String
    Dim oldPath, newPath As String
   
    Set rngAll = Range([D2], Cells(Rows.Count, "D").End(3))     '// 복사할 파일이 있는 범위 설정
    oldPath = Cells(3, "H").Value       '// 복사할 파일의 경로
    newPath = Cells(5, "H").Value       '// 복사될 파일의 경로
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    For Each rngC In Selection      '// Selection 대신에 rngAll 을 선택하면 범위설정 구간 반복 처리
        If InStr(newPath, "교정") > 0 And Cells(rngC.Row, "F") <> "Copyed" Then  '// 파일이 복사되지 않았으면
            If Cells(rngC.Row, "E") = "교정파일" Then
                oldName = oldPath & "\" & Cells(rngC.Row, "D")
                newName = newPath & "\" & Cells(rngC.Row, "D")
               
                If Dir(oldName, vbDirectory) = "" Then          '// 파일이나 폴더가 없다면
                    Cells(rngC.Row, "F").Value = "파일없음"
                Else
                    If Dir(newName, vbDirectory) = Empty Then
                        FSO.CopyFile oldName, newName       '// 파일 복사
                        Cells(rngC.Row, "F").Value = "Copyed"
                    Else
                        Cells(rngC.Row, "F").Value = "동일파일 존재"
                    End If
                End If
            Else    '// Cells(rngC.Row, "E") 가 비어있으면
                Debug.Print rngC.Row & "행은 복사할 수 없습니다"
            End If
        Else
            Debug.Print rngC.Row & "행은 이미 복사되었습니다"
        End If
    Next rngC
End Sub

복사하려는 곳(newPaht)에 파일이 존재해도 파일 복사하고 현재 폴더(oldPath)에 있는 파일을 지우고자 한다면

                    If Dir(newName, vbDirectory) = Empty Then
                        Name oldName As newName    '// 파일을 이동시켜라
                        Cells(rngC.Row, "F").Value = "Copyed"
                    Else
                        VBA.FileCopy oldName, newName       '// 파일 복사
                        Cells(rngC.Row, "F").Value = "Copyed"
                        On Error Resume Next
                        SetAttr oldName, vbNormal     '// 파일 속성을 변경시키고
                        Kill oldName                          '// 파일을 삭제하라
                        On Error GoTo 0
                    End If

로 변경해주면 된다.

네이버 지식인에 올라온 자료가 궁금해서 작성을 해봤다.

배열에 대한 이해도 좀 더 높일 겸해서 VBA 로 코드를 작성해 보면서 디버깅 기능을 이용하여 중간 중간 확인 작업도 해봤다.

매장데이터분리.xlsm

Sub 문자_숫자_분리추출()
'// Alt + F11 키를 눌러서 [삽입] - [모듈] 에 이 VBA 코드를 붙여넣기하고 F5 키를 눌러서 실행
    Dim rngC, rngAll As Range
    Dim v
    Dim k As Long
    Dim i, c, n As Integer
   
    Set rngAll = Range("A2:A" & Cells(Rows.Count, "A").End(3).Row)      '// 범위 구간 설정
    Range([B1], Cells(Rows.Count, "B").End(3)).Offset(1).Resize(, 2).ClearContents    '// 값을 뿌릴 영역 초기화
   
    For Each rngC In rngAll
        v = Split(rngC, "+")       '// + 를 구분자로 셀을 분리
        ReDim Num(1 To 1): ReDim Dat(1 To 1): n = 0   '// 배열 및 배열에 사용할 변수 초기화
        For i = LBound(v) To UBound(v)      '// + 구분자로 분리한 배열의 개수만큼 반복
            n = n + 1
            ReDim Preserve Num(1 To n): ReDim Preserve Dat(1 To n)     '// 기존값을 유지하면서 배열크기를 다시 설정
            For c = 1 To Len(v(i))                      '// 전체 문자길이 만큼 반복
                If IsNumeric(Mid(v(i), c, 1)) Then  '// 문자열이 숫자일 경우
                    Num(n) = Num(n) & Mid(v(i), c, 1)   '// 각 숫자를 합쳐감
                Else
                    Dat(n) = Dat(n) & Mid(v(i), c, 1)   '// 숫자가 아닌 것을 합쳐감
                End If
            Next c
            'Debug.Print "행 =" & rngC.Row & "  숫자 i =" & i & "  숫자 n =" & n & "  Dat =" & Trim(Dat(n)) & "  Num =" & Num(n)
           
            '// 셀에 뿌리는 작업   처음 k =0 Cells(k + 2, "B") 는 B2 셀
            Cells(k + 2, "B") = Trim(Dat(n))
            Cells(k + 2, "C") = Num(n)
            k = k + 1
        Next i
    Next rngC
   
    Set rngAll = Nothing    '// 메모리 비우기   
End Sub

작업을 하다보면 선택한 폴더의 파일만 전부 엑셀 시트에 뿌리고, 엑셀 시트에서 원하는 결과를 도출하는 작업을 해야 하는 경우가 생긴다.

VBA 를 조금씩 배워가면서 셀 표기를 직관적으로 이해할 수 있게 하는게 여러모로 편하고 나중에 확인하기도 쉽다는 걸 배운다.

Cells(r, "J") 에서 r 변수는 row(행)의 약자로 사용하는게 더 좋다는 판단이 들었다. 처음에는 iRow 라는 변수를 쓰기도 했다.

sub Folder 의 자료는 가져오지 않는다. 가져오면 작업하는데 방해가 되어서 선택한 폴더의 자료만 가져오게 했다.

Sub CurrentPath_FindFile()      '// 현재 폴더의 파일 가져오기
    Dim objFolder, objFso, objFile, objSubFolder
    Dim fPath As Variant    '// 경로(Path) 변수 선언
    Dim r As Long
    Dim openMsg As String

    On Error Resume Next     '// 에러가 발생해도 계속 수행하라
    openMsg = "파일을 가져올 경로를 직접 지정하려면 Yes를 눌러주세요 "
    If MsgBox(openMsg, vbYesNo) = vbYes Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = "C:\Excel Basics"
            .Show
            fPath = .SelectedItems(1)   '// 선택될 폴더를 경로 변수에 저장
        End With
    Else
        fPath = Cells(3, "A") & "\"     '// 셀이 비어있으면 C:\ 폴더에 있는 파일 리스트를 가져옴
'        Exit Sub
    End If
    If Err.Number <> 0 Or fPath = False Then Exit Sub
    On Error GoTo 0

    Set objFso = CreateObject("Scripting.FileSystemObject")     '// 파일 시스템 객체 생성
    Set objFolder = objFso.GetFolder(fPath)       '// 현재 폴더를 구함..
   
    Range([J1], Cells(Rows.Count, "j").End(3)).Offset(1).Resize(, 2).Clear    '// 데이터를 뿌릴 영역 초기화
   
    r = 1
    For Each objFile In objFolder.Files     '// 현재 폴더 내의 전체 파일 셀에 저장
        r = r + 1
'        Cells(r, "I") = fPath
        Cells(r, "J") = objFile.Name
    Next
   
End Sub

막상 자료를 찾으려고 하면 작업한 파일을 찾아내기가 쉽지 않아 필요할 때 바로 이용할 수 있도록 VBA 코드를 원하는 형태에 맞게 수정해서 저장해둔다.

배경색 저장하는 것은 interior.colorindex 속성을 이용하면 된다.

중복자료의 의미는 두 Sheet 간에 서로 일치하는 데이터인 경우에 배경색을 칠하도록 한다.

즉, 작업을 해야 할 파일에다가 중복되는 자료를 표시하는 것이다.

Cell_Find.txt

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, "D"), sht1.Cells(Rows.Count, "D").End(3))
    Set Target = sht2.Range(sht2.Cells(2, "A"), sht2.Cells(Rows.Count, "A").End(3))
  
    sht1.Select
'    rngAll.Interior.ColorIndex = xlNone     '// 구간에 표시된 색상 전부 제거
  
    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  '// 무한 루프 시작
                FindCell.Interior.ColorIndex = 15    '// 회색으로 설정
                Set C = Target.FindNext(C)   '// 다음셀을 찾음
            Loop While Not C Is Nothing And strAddr <> C.Address    '// 찿는 셀이 없거나 첫번째 셀이면 루프문 종료
        End If
    Next
    Application.StatusBar = "작업완료"
   Set rngAll = Nothing    '// 메모리 비우기
End Sub

같은 자료를 하나의 셀로 보여주도록 처리하는 VBA 코드이다.

첨부파일에는 여러개의 코드가 포함되어 있다.

VBA 고수분이 알려준 코드도 같이 포함되어 있고, 초보적인 수준으로 만든 코드도 포함되어 있다.

셀Join.xlsm

Sub collection2()
    Dim sht1, sht2 As Worksheet     '// 다른 시트 자료 가져오는 것까지 고려한 변수 선언
    Dim rngC, rngT, rngData As Range
    Dim X As New collection
    Dim r, n, i As Long
    Dim Dat As Variant

    Application.ScreenUpdating = False      '// 화면 업데이트 (일시) 중지
    Set sht1 = Sheets("Main")     '// 화면에 뿌릴 시트
    Set sht2 = Sheets("Data")   '// 가져올 데이터 시트
    Range("G2:H" & Cells(Rows.Count).Row).Offset(1).ClearContents   '// 결과를 뿌릴 화면 초기화
    Set rngData = sht2.Range(sht2.Cells(4, "B"), sht2.Cells(Rows.Count, "B").End(3))  '// 가져올 데이터 영역
  
    On Error Resume Next   '// 에러가 발생했을 경우 계속해서 다음을 실행하라
    r = 2
    For Each rngC In rngData    '// 데이터 시트의 B3셀부터 B의 마지막셀까지 반복하라
        X.Add rngC.Value, CStr(rngC.Value)      '// 중복된 데이터는 저장하지 마라
        If Err.Number <> 457 Then  '// 만일 에러가 발생하지 않았으면
            r = r + 1
            Cells(r, "G") = rngC
        End If
        Err.Clear
    Next rngC
   
    For Each rngT In Range([G3], Cells(Rows.Count, "G").End(3))
        ReDim Dat(1 To 1): n = 0   '// 배열 및 배열에 사용할 변수 초기화
        For Each rngC In rngData
            If rngC = rngT Then
                n = n + 1       '// 사용할 배열의 크기를 1씩 늘려감
                ReDim Preserve Dat(1 To n)   '// 기존값을 유지하면서 배열크기를 다시 설정
                Dat(n) = rngC.Offset(, 1)
            End If
        Next rngC
        rngT.Offset(, 1) = Join(Dat, ", ")
    Next rngT
    Set rngData = Nothing   '// 메모리 비우기
End Sub

인터넷상에서 자료를 가져오면 한 셀내에 데이터가 콤마로 구분되어 있는 경우도 있다.

이럴 경우 분리하는 VBA 코드이다.

Sub 셀분리()
    Dim rngC, rngAll As Range
    Dim r, c, k As Long
    Dim tmp
   
    Application.ScreenUpdating = False
    Set rngAll = Range([A3], [A3].End(4))   '// 빈셀이 없을 경우에는 [A3].End(4) 로 편함
   
    r = 1
    For Each rngC In rngAll
        tmp = Split(rngC.Offset(0, 1), ",")     '// 콤마로 분리하여 tmp 배열에 저장
        For k = LBound(tmp) To UBound(tmp)  '// 배열의 갯수만큼 반복
            r = r + 1
            Cells(r, "C") = rngC.Value
            Cells(r, "D") = tmp(k)
        Next k
    Next rngC
End Sub

조건에 맞는 데이터를 가져오는데 중복이 발생한 데이터는 제거하고 가져오는 VBA 코드이다.

고급필터_샘플.xlsm

본 파일에는 고급필터를 이용하여 자료를 가져오는 VBA 코드와 Collection 함수를 이용하여 데이터를 가져오는 VBA코드가 같이 포함되어 있다.

Sub collection()
    Dim sht1, sht2 As Worksheet
    Dim rngC As Range
    Dim rngData As Range
    Dim rngTarget As Range
    Dim X As New collection

    Application.ScreenUpdating = False      '// 화면 업데이트 (일시) 중지
    Set sht1 = Sheets("메인")     '// 화면에 뿌릴 시트
    Set sht2 = Sheets("데이터")   '// 가져올 데이터 시트
    Range("I2:I" & Cells(Rows.Count).Row).Offset(1).ClearContents
    Set rngData = sht2.Range(sht2.Cells(2, "C"), sht2.Cells(Rows.Count, "C").End(3))  '// 가져올 데이터 영역
   
    On Error Resume Next   '// 에러가 발생했을 경우 계속해서 다음을 실행하라
    For Each rngC In rngData    '// 데이터 시트의 C2셀부터 C의 마지막셀까지 반복하라
        If rngC.Offset(, -2) = sht1.Cells(3, "G").Value And rngC.Offset(, -1) = sht1.Cells(3, "H").Value Then
            X.Add rngC, CStr(rngC)      '// 중복된 데이터는 저장하지 마라
            If Err.Number <> 457 Then   '// 이미 할당된 요소(element) 가 아니면
                rngC.Copy Cells(Rows.Count, "I").End(3)(2)
            End If

            Err.Clear
        End If
    Next rngC
    Set rngData = Nothing   '// 메모리 비우기
    MsgBox Range([I3], Cells(Rows.Count, "I").End(3)).Rows.Count & "개 가져옴"
End Sub

네이버지식인에 VBA 고수분이 답변해준 내용인데

나중에 활용할 일이 있을 거 같아서 코드를 실행해보고 인터넷을 뒤져서 의미가 뭔지 파악하고 추가 해설까지 적어서 기록해둔다.

For Next 문을 돌리고 RemoveDuplicates 함수를 이용해도 될 거 같은데 Collection 과 Cstr 함수를 이용하고 동적배열 ReDim Preserve 를 사용하고, Transpose 함수 기능을 사용했다.

아직은 내가 잘 사용을 안해본 함수/기능을 많이 사용했다.

Err Number 가 의미하는 것을 알려고 구글링해서 https://support.microsoft.com/en-us/kb/146864 에서 코드 부분만 내블로그에 적어두었다.

항목별갯수_VBA.xlsm

Sub 항목별갯수()
    Dim X As New Collection
    Dim rngAll, rngC, Rev() As Variant
    Dim i As Integer, n As Integer
   
    rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    Range("D2:E" & Rows.Count).ClearContents
    On Error Resume Next   '// 에러가 발생했을 경우 계속해서 다음을 실행하라
    For Each rngC In rngAll
        X.Add rngC, CStr(rngC)

        '//컬렉션 오브젝트의 기본형태는 [오브젝트명.Add Item, key, (before), (after)]
        '//여기서 key 요소는 unique한 텍스트, 즉 중복되지 않는 텍스트일 경우에만 유효하다
        '// 즉, 위에서 나왔던 값을 밑에서 또 만나면 에러가 발생하게 되고, 따라서 아이템에 추가가 되지 않는다

        If Err.Number <> 457 Then   '// 이미 할당된 요소(element) 가 아니면
            Set rngDB = Range([A2], Cells(Rows.Count, "A").End(3))
            ReDim Preserve Rev(1 To 2, n)
            Rev(1, n) = rngC
            Rev(2, n) = WorksheetFunction.CountIf(rngDB, rngC)
            n = n + 1
        End If
        Err.Clear
    Next rngC
    Range("D2").Resize(n, 2) = Application.Transpose(Rev)
End Sub

현재 Sheet 를 제외하고 모든 시트를 순환하면서 조건을 만족하는 데이터를 복사해오는 VBA 코드이다.

조건에 맞는 값이 들어있는 셀을 찾는 것은 Find 함수를 이용하고

여기에 각 시트만 순환하는 For Each sht in Sheets 만 더 추가한 것이다.

그리고 If sht.Name <> ActiveSheet.Name Then   '// 현재 시트와 순환하는 시트이름이 다르면

기존 FIND VBA 함수를 약간 응용한 것이라고 보면 된다.

Option Explicit
Sub 시트순환결과가져오기()
    Dim sht As Worksheet    '// 각 시트를 순환할 변수
    Dim strAddr As String     '// 임시주소를 저장할 변수
    Dim C As Range
    Dim FindCell As String    '// 찾는 셀이 들어간 변수
   
    If Len(Cells(3, "C")) = 0 Then Exit Sub
    FindCell = Cells(3, "C").Value
    Application.ScreenUpdating = False      '// 화면 업데이트 일시 정지
    Range("A9:H" & Rows.Count).ClearContents    '// A9 셀부터 H 마지막 셀까지 전부 내용 지우기
   
    For Each sht In Sheets
         If sht.Name <> ActiveSheet.Name Then   '// 현재 시트와 순환하는 시트이름이 다르면

            With sht.Columns(2)     '// 찾을 값이 B열에 있을 경우
               Set C = .Find(what:=FindCell, Lookat:=xlPart)    '// 부분적으로 일치하는 걸 찾기
               If Not C Is Nothing Then
                   strAddr = C.Address  '// 찾은 셀의 주소를 변수에 넣음
                   Do
                       C.EntireRow.Copy Cells(Rows.Count, "A").End(3)(2)    '// 찾는 값이 들어있는 행 전체를 복사
                       Set C = .FindNext(C)
                   Loop While Not C Is Nothing And C.Address <> strAddr
               End If
            End With
        End If
    Next sht
End Sub

특정 셀에 데이터 입력하고 엔터키를 치면 자동으로 조건에 맞는 데이터를 가져오는 VBA 코드로 위의 코드와 동일한데 달라진 셀이 어디인지만 찾아보면 된다.

Private Sub Worksheet_Change(ByVal FindCell As Range)
    Dim sht As Worksheet    '// 각 시트를 순환할 변수
    Dim strAddr As String     '// 임시주소를 저장할 변수
    Dim C As Range
   
    If FindCell.Address <> "$C$3" Then Exit Sub
    Application.ScreenUpdating = False      '// 화면 업데이트 일시 정지
    Range("A9:H" & Rows.Count).ClearContents    '// A9 셀부터 H 마지막 셀까지 전부 내용 지우기
   
    For Each sht In Sheets
         If sht.Name <> ActiveSheet.Name Then   '// 현재 시트와 순환하는 시트이름이 다르면
            With sht.Columns(2)     '// 찾는 값이 B열에 있을 경우
               Set C = .Find(what:=FindCell, Lookat:=xlPart)    '// 부분적으로 일치하는 걸 찾기
               If Not C Is Nothing Then
                   strAddr = C.Address  '// 찾은 셀의 주소를 변수에 넣음
                   Do
                       C.EntireRow.Copy Cells(Rows.Count, "A").End(3)(2)    '// 찾는 값이 들어있는 행 전체를 복사
                       Set C = .FindNext(C)
                   Loop While Not C Is Nothing And C.Address <> strAddr
               End If
            End With
        End If
    Next sht
End Sub

네이버지식인에 srt 자막의 타임코드 오류가 발생한 것을 수정하는 걸 해보고 싶어서 해봤는데 생각외로 오류가 있는 부분 때문에 시간이 많이 걸렸다.

srt 자막정리.xlsm

Japan_modify.srt

Sub CellClear()
    Dim rngC As Range       '// 선택영역 각 셀을 넣을 변수
    Dim rngAll As Range      '// 선택영역 전체 범위 변수
   
    Cells(2, "A").Select   
    Application.ScreenUpdating = False      '// 화면 업데이트 (일시)정지
    If Cells(Rows.Count, "A") > Cells(Rows.Count, "B") Then
        Range([A1], Cells(Rows.Count, "A").End(3)).Offset(1).EntireRow.Clear
    Else
        Range([B1], Cells(Rows.Count, "B").End(3)).Offset(1).EntireRow.Clear
    End If

    Range([A2], Cells(Rows.Count, "B")).NumberFormat = "@"   '// 텍스트 서식으로

End Sub

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

Sub srt자막수정()
    Dim rngC, rngAll As Range
    Dim v, v1, v2, s1, s2
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    For Each rngC In rngAll
        If InStr(rngC, "-->") > 0 Then
            v = Split(rngC, "-->")
            v1 = Split(Trim(v(0)), ":")
            v2 = Split(Trim(v(1)), ":")
           
            If Len(v1(2)) > 5 Then
                Debug.Print "v1 자리수 : " & v1(2) & "  행번호 = " & rngC.Row
                rngC.Offset(, 2).Interior.ColorIndex = 36
            End If
           
            If Len(v2(2)) > 5 Then
                Debug.Print "v2 자리수 : " & v2(2) & "  행번호 = " & rngC.Row
                rngC.Offset(, 2).Interior.ColorIndex = 38
            End If
           
            If InStr(Trim(v1(2)), ",") = 0 Then
                    s1 = Left(v1(2), 2) & "," & Mid(v1(2), 3, 3)
            Else
                s1 = v1(2)
            End If
           
            If InStr(v2(2), ",") = 0 Then
                s2 = Left(v2(2), 2) & "," & Mid(v2(2), 3, 3)
            Else
                s2 = v2(2)
            End If
            rngC.Offset(, 1) = v1(0) & ":" & v1(1) & ":" & s1 & " --> " & v2(0) & ":" & v2(1) & ":" & s2
        Else
            rngC.Offset(, 1) = rngC
        End If
    Next rngC
End Sub

영자막과 한글자막을 통합하여 정리하는 걸 편하게 하려고 궁리중인데 잘 안된다.

아래 로직은 실패한 로직이다. 하지만 기록을 해두고 나중에 다른 각도로 접근해서 풀어볼 생각이다.

자막 내보내기 로직에서 문제의 해결책을 찾아야 할 거 같다.

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
        On Error Resume Next
        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

현재 엑셀 시트를 CSV 파일로 내보내기하는 VBA 코드다.

Sub CurrentSheet_SaveAsCSV()
    Range("A1:A" & Cells(Rows.Count, "E").End(3).Row).Copy
    '// 복사할 범위 지정하여 복사
    With Application.FileDialog(msoFileDialogSaveAs)
        .FilterIndex = 15
        .InitialFileName = ActiveSheet.Name & " " & Format(Date + Time, "yyyy-mm-dd hhmmss") & ".csv"
        If .Show Then
            Application.DisplayAlerts = 0
            .Execute
            Application.DisplayAlerts = 1
        End If
    End With
    MsgBox "파일 복사 완료"
End Sub

엑셀 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

공백을 구분자로 주소를 분리하여 저장하는 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