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

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

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

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

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

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

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

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

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

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

이 코드는 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

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

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

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

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

application .GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)

- FileFilter : 파일 필터링 조건을 지정하는 문자열, 생략하면 모든 파일 종류를 표시

- FilterIndex : 1부터 FileFilter 에서 지정한 필터 개수까지 기본 파일 필터링 조건의 인덱스 번호를 지정

- Title : 대화 상자의 제목을 지정. 생략하면 대화 상자의 제목은 "열기"로 표기됨

- ButtonText : 매킨토시 전용

- MultiSelect : True 이면 파일을 여러개 선택 가능, False 이면 1개만 선택 가능, 생략하면 False

GetOpenFilename 메서드를 이용해서 표준 열기 대화상자를 실행하면 항상 마지막으로 선택했던 폴더가 표시된다.

fNames = Application.GetOpenFilename(MultiSelect:=True)

fNames = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)

fNames = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Choose Files", MultiSelect:=True)

ThisWorkbook.Path    '// 현재 폴더의 경로

FileFilter 를 열어서 여러개 지정하려면, "MS-Word, *.doc, Text Files, *.txt" 와 같은 형태로 하면 된다.

파일을 1개만 선택하게 하려면, MultiSelect:=False 로 설정한다.

Sub MultiFiles()
    Dim fNames As Variant
    Dim Msg As String
    Dim i As Long
   
    fNames = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
    On Error Resume Next
    If TypeName(fNames) = "Boolean" Then Exit Sub   

     '// 취소 선택 시 매크로 종료, 변수를 Variant 아닌 String 으로 하면 에러가 발생됨
    If IsArray(fNames) Then
        Msg = "You selected:" & vbNewLine
        For i = LBound(fNames) To UBound(fNames)
            Msg = Msg & fNames(i) & vbNewLine
        Next i
        MsgBox Msg
    End If
End Sub

파일을 열고자 한다면

Workbooks.Open FileName:=fName

Sub Open_FileDialog()
    Dim fName As Variant
    '// 하나의 필터 규칙에 여러 개의 파일 형식을 포함하고자 할 경우에는 세미콜론(;) 을 사용
    fName = Application.GetOpenFilename(FileFilter:="Text Files, *.txt ; *.smi ; *.srt", MultiSelect:=False)
    If TypeName(fName) = "Boolean" Then
        Exit Sub    '// 취소 선택 시 매크로 종료
    Else
        Shell "Notepad.exe " & fName
    End If
End Sub

연습하면서 사용했던 파일

fileToOpen.xlsm

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

이럴 경우 분리하는 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

출처 : https://support.microsoft.com/en-us/kb/146864

The following table contains a list of the trappable error codes you may encounter when you use the Err function.

   Error code   Error message
   ----------   -------------
   3            Return without GoSub
   5            Invalid procedure call
   6            Overflow
   7            Out of memory
   9            Subscript out of range
   10           Duplicate definition (versions 5.0 and 7.0)
   10           This array is fixed or temporarily locked (version97)
   11           Division by zero
   13           Type mismatch
   14           Out of string space
   16           String formula too complex (versions 5.0 and 7.0)
   16           Expression too complex (version 97)
   17           Can't perform requested operation
   18           User interrupt occurred
   20           Resume without error
   28           Out of stack space
   35           Sub or function not defined (versions 5.0 and 7.0)
   35           Sub, function, or property not defined (version 97)
   47           Too many DLL application clients (version 97)
   48           Error in loading DLL
   49           Bad DLL calling convention
   51           Internal error
   52           Bad file name or number
   53           File not found
   54           Bad file mode
   55           File already open
   57           Device I/O error
   58           File already exists
   59           Bad record length
   61           Disk full
   62           Input past end of line
   63           Bad record number
   67           Too many files
   68           Device unavailable
   70           Permission denied
   71           Disk not ready
   74           Can't rename with different drive
   75           Path/File access error
   76           Path not found
   91           Object variable not set (versions 5.0 and 7.0)
   91           Object variable or With block variable not set
                (version 97)
   92           For Loop not initialized
   93           Invalid pattern string
   94           Invalid use of Null
   95           User-defined error (versions 5.0 and 7.0 only)
   298          System DLL could not be loaded (version 97)
   320          Can't use character device names in specified file names
                (version 97)
   321          Invalid file format (version 97)
   322          Can't create necessary temporary file (version 97)
   323          Can't load module; invalid format (versions 5.0 and 7.0)
   325          Invalid format in resource file (version 97)
   327          Data value named was not found (version 97)
   328          Illegal parameter; can't write arrays (version 97)
   335          Could not access system registry (version 97)
   336          ActiveX component not correctly registered (version 97)
   337          ActiveX component not found (version 97)
   338          ActiveX component did not correctly run (version 97)
   360          Object already loaded (version 97)
   361          Can't load or unload this object (version 97)
   363          Specified ActiveX control not found (version 97)
   364          Object was unloaded (version 97)
   365          Unable to unload within this context (version 97)
   368          The specified file is out of date. This program requires
                a newer version (version 97)
   371          The specified object can't be used as an owner form for
                Show (version 97)
   380          Invalid property value (version 97)
   381          Invalid property-array index (version 97)
   382          Property Set can't be executed at run time (version 97)
   383          Property Set can't be used with a read-only property
                (version 97)
   385          Need property-array index (version 97)
   387          Property Set not permitted (version 97)
   393          Property Get can't be executed at run time (version 97)
   394          Property Get can't be executed on write-only property
                (version 97)
   400          Form already displayed; can't show modally (version 97)
   402          Code must close topmost modal form first (version 97)
   419          Permission to use object denied (version 97)
   422          Property not found (version 97)
   423          Property or method not found
   424          Object required
   425          Invalid object use (version 97)
   429          ActiveX component can't create object or return
                reference to this object (version 97)
   430          Class doesn't support OLE Automation
   430          Class doesn't support Automation (version 97)
   432          File name or class name not found during Automation
                operation (version 97)

   438          Object doesn't support this property or method
   440          OLE Automation error
   440          Automation error (version 97)
   442          Connection to type library or object library for remote
                process has been lost (version 97)
   443          Automation object doesn't have a default value
                (version 97)
   445          Object doesn't support this action
   446          Object doesn't support named arguments
   447          Object doesn't support current locale settings
   448          Named argument not found
   449          Argument not optional
   449          Argument not optional or invalid property assignment
                (version 97)
   450          Wrong number of arguments
   450          Wrong number of arguments or invalid property assignment
                (version 97)
   451          Object not a collection
   452          Invalid ordinal
   453          Specified DLL function not found
   454          Code resource not found
   455          Code resource lock error
   457          This key is already associated with an element of this
                collection (version 97)
   458          Variable uses a type not supported in Visual Basic
                (version 97)
   459          This component doesn't support events (version 97)
   460          Invalid clipboard format (version 97)
   461          Specified format doesn't match format of data
                (version 97)
   480          Can't create AutoRedraw image (version 97)
   481          Invalid picture (version 97)
   482          Printer error (version 97)
   483          Printer driver does not support specified property
                (version 97)
   484          Problem getting printer information from the system.
                Make sure the printer is set up correctly (version 97)
   485          Invalid picture type (version 97)
   486          Can't print form image to this type of printer
                (version 97)
   735          Can't save file to Temp directory (version 97)
   744          Search text not found (version 97)
   746          Replacements too long (version 97)
   1000         Classname does not have propertyname property
                (versions 5.0 and 7.0)
   1001         Classname does not have methodname method
                (versions 5.0 and 7.0)
   1002         Missing required argument argumentname
                (versions 5.0 and 7.0)
   1003         Invalid number of arguments (versions 5.0 and 7.0)
   1004         Methodname method of classname class failed
                (versions 5.0 and 7.0)
   1005         Unable to set the propertyname property of the classname
                class (versions 5.0 and 7.0)
   1006         Unable to get the propertyname property of the classname

                class (versions 5.0 and 7.0)
   31001        Out of memory (version 97)
   31004        No object (version 97)
   31018        Class is not set (version 97)
   31027        Unable to activate object (version 97)
   31032        Unable to create embedded object (version 97)
   31036        Error saving to file (version 97)
   31037        Error loading from file (version 97)
				

현재 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

날짜를 표시하는 VBA 코드다.

/ 는 Split 함수를 이용하여 배열로 저장하면 간단하게 해결할 수 있다. 함수식을 사용하면 계산이 좀 더 복잡해진다.

DateSerial(year, month, day) 를 이용하여 날짜를 표시한다.

그리고 NumberFormat 으로 서식을 지정해줘야 깔끔하게 정리가 된다.

Resize 기능을 이해하려면 아래 코드를 한줄씩 실행해보면 선택영역이 어떻게 변경되는지 확인할 수 있다.

Sub resize_func()
    Range("A3:A5").Offset(, 1).Resize(, 3).Select
    Range("A3").Resize(RowSize:=2, ColumnSize:=2).Select
    Range("A3").Resize(2).Select
    Range("A3").Resize(, 2).Select
    Range("A3:A5").Resize(, 2).Select
End Sub

Sub date_extract()
    Dim v
    Dim rngC As Range
    Dim rngAll As Range
  
    Set rngAll = Range([A3], Cells(Rows.Count, "A").End(3))
    For Each rngC In rngAll     '// A열의 마지막 데이터가 있는 곳까지
        v = Split(rngC, "/")    '// A열의 셀을 / 로 구분하여 배열로 저장
        rngC.Offset(0, 1) = v(2)
        rngC.Offset(0, 2) = v(0)
        rngC.Offset(0, 3) = v(1)
        rngC.Offset(0, 4) = DateSerial(v(2), v(0), v(1))
    Next rngC
    rngAll.Offset(, 1).Resize(, 3).NumberFormat = "General"
    rngAll.Offset(, 4).NumberFormat = "yyyy-mm-dd"
    Set rngAll = Nothing
    MsgBox "작업완료"
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

수정을 하거나 중간 중간 확인을 해야 하는 상황일 때에는 시작행, 마지막행을 가변적으로 지정할 필요가 있다.

이때에는 코드를 아래처럼 만들어서 사용하면 좀 더 편하고 좋다.

VBA 도 조금 알게 되니까 범위지정을 얼마나 편리하게 할 것인가, 간단간단한 팁을 알아두면 여러모로 유용하게 사용할 수가 있는 거 같다.

    Dim C, rngAll As Range
    Dim sRow    '// 시작할 행의 변수
    Dim v
    Application.StatusBar = True
    v = InputBox("시작할 행의 수를 입력하세요")
    sRow = Trim(Split(v, "/")(0))
    If sRow = vbNullString Then Exit Sub           '// 취소 선택시 매크로 중단
    If Not IsNumeric(sRow) Then Exit Sub         '// 입력한 값이 숫자가 아닌 경우 매크로 중단
       
    If InStr(v, "/") > 0 Then
        eRow = Trim(Split(v, "/")(1))  '// 마지막 행
    End If
    Debug.Print "Last Row : " & eRow
    If eRow Then
        Set rngAll = Range(Cells(sRow, "G"), Cells(eRow, "G"))
    Else
        Set rngAll = Range(Cells(sRow, "G"), Cells(Rows.Count, "G").End(3))
    End If

현재 엑셀 시트를 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