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

영어 검색어인 경우에는 asterisk 가 들어간 검색어가 될 수도 있다.

DB에 SQL 로 접속할 경우, 관련 자료가 하나도 없다고 결과를 돌려줄 수도 있다.

이럴 경우에는

    Keyword = Application.InputBox("검색 키워드를 입력하세요", "검색어", Type:=2)
    If InStr(Keyword, "'") > 0 Then    '// 영어 검색어에는 asterisk 가 포함되어 있을 수 있으므로
        Keyword = Replace(Keyword, "'", "\'")
    End If

와 같이 처리해주면 된다.

어제 완전 삽질을 했다.

데이터 갯수 : 4만개

해야 할 일 : 엑셀 시트에 있는 파일명이 실제 PC의 폴더에 존재하는지 여부와 해당 폴더명을 엑셀에 기록

I5-4200 CPU 2.3GHz, 8G 메모리, SSD 를 사용하는 노트북과 AMD 6100 CPU(6-Core) 3.3GHz, 8G 메모리, SSD(Plexstor 6M Pro) 를 사용하는 데스크탑에서 동일한 VBA 코드를 가지고 돌려봤더니, 노트북은 20분이 안걸린다. 데스크탑은 49분이나 걸렸다.

왜 이런 현상이 벌어지나 하고 Desktop PC 악성코드 검사를 해서 악성코드도 몇개 발견, 치료했고, ASUS 메인보드 BIOS 를 최근에는 업데이트를 안해서 구글링을 해서 업데이트도 했다.

처음에는 USB로 BIOS Update 데이터를 받아서 재부팅하고 하려고 있는데, HDD(하드디스크)상에 존재하는 파일을 쉽게 찾을 수 있는 기능이 있어서 그걸로 BIOS 를 업데이트했다.

이런 삽질 하느라고 VBA 코드가 잘못된 것은 없나 확인하면서 돌려보고, 중간에 PC 상태 업데이트를 하면서 진행하다보니, VBA 파일이 깨졌는지 열리지가 않는다.

수정하면서 짠 VBA 코드가 다 날라가 버렸다. ㅠㅠㅠ

다시 수정하고, VBA 코드를 블로그나 홈페이지에 백업을 해두지 않으면 안되겠다는 생각이 들어 일부는 기록을 해두었다.

열심히 삽질을 했지만, AMD CPU 가 성능을 제대로 내주지 못한다는 것으로 결론을 1차 내렸다.

하지만, 내가 작업하는 파일, VBA 코드 등은 Desktop PC에서 작업하는게 편하다. 23인치 모니터 2대를 놓고 비교해보면서 작업하는데 어찌 노트북 화면에 비유할 수 있으랴..

그래서, 이번에는 PC의 특정 폴더와 서브폴더에 존재하는 모든 파일을 엑셀 시트에 기록하는 VBA 코드로 돌려보니 1분이 안걸린다. 여기까지는 좋았다.

아래 코드로 두 Sheet 의 데이터가 일치하는 것만 표시하는 것을 했더니 동일한 반복작업을 4만번씩 실행하는 통에 속도가 더 느린 거 같아서 중간에 ESC 키를 눌러서 중단시켜 버렸다.

아래 코드는 데이터가 적을 경우에는 나름 효율적(?)인 코드이다. 그러나 데이터가 방대해질 경우에는 사용해서는 안되는 코드라는게 ....

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&, n&, k&, s&, sRow&, oldT As Single
  
    Application.StatusBar = True

    Application.ScreenUpdating = False
    oldT = Timer()
    Set sht1 = Sheets("Main")   '// Main 워크시트는 현재 시트
    Set sht2 = Sheets("FileList")   '// FileList 워크시트는 데이터가 있는 Target 시트
    sRow = Cells(Rows.Count, "A").End(3)(2).Row    '// A열의 값이 들어있는 마지막 셀을 첫셀로 지정
    Set rngAll = sht1.Range(sht1.Cells(sRow, "G"), sht1.Cells(Rows.Count, "G").End(3))
    Set Target = sht2.Range(sht2.Cells(2, "B"), sht2.Cells(Rows.Count, "B").End(3))
  
    sht1.Select     '// 작업의 실수를 방지하기 위해 해당 시트 선택
    sht1.Range(sht1.Cells(1, "A"), sht1.Cells(Rows.Count, "A").End(3)).Offset(1).Clear
   
    On Error Resume Next
    i = Range(Cells(sRow, "G"), Cells(Rows.Count, "G").End(3)).SpecialCells(2).Count
    For Each FindCell In rngAll.Cells
        n = n + 1
        If (n Mod 500) = 0 Then
            Application.ScreenUpdating = True
            Application.StatusBar = "셀: " & FindCell.Address(0, 0) & " / " & FindCell & " / " & Format(n / i, "0.00% 진행중... ") & "경과시간: " & Format(Timer() - oldT, "0.00초 걸림"): DoEvents
            Application.ScreenUpdating = False
        End If
        Set C = Target.Find(what:=FindCell, Lookat:=xlWhole)
        '// Target 범위에서 FindCell 과 100% 일치하는 데이터를 찾아 C에 넣어라
        If Not C Is Nothing Then    '// 찾는 값이 있으면
            strAddr = C.Address     '// 최초 셀 주소를 기억하게 strAddr 에 저장
            Do  '// 무한 루프 시작
                If Len(Cells(FindCell.Row, "A")) = 0 Then
                    Cells(FindCell.Row, "A") = C.Offset(, -1)
                    s = s + 1
                Else
                    Cells(FindCell.Row, "A") = Cells(FindCell.Row, "A") & vbNewLine & C.Offset(, -1)
                    Cells(FindCell.Row, "A").Interior.ColorIndex = 26
                    k = k + 1
                End If
                Set C = Target.FindNext(C)   '// 다음셀을 찾음
            Loop While Not C Is Nothing And strAddr <> C.Address    '// 찿는 셀이 없거나 첫번째 셀이면 루프문 종료
        End If
    Next
    Application.StatusBar = "작업완료"
   Set rngAll = Nothing    '// 메모리 비우기
   MsgBox s & " 개 신규 " & vbLf & k & " 개 중복 " & vbLf & Format(Timer() - oldT, "0.00초 걸림"), 64, Now()
End Sub

이번에는 비교할 자료가 중복이 존재하는지 정렬(sort)를 하고 나서 위 아래 셀간에 비교문을 만들어서 중복된 자료를 찾아서 제거했다.

그리고 VLOOKUP VBA 코드를 돌렸다.

Sub Vlookup_VBA()
'Application.VLOOKUP(lookup_value, table_array, column_index, range_lookup)
    Dim sht1, sht2    As Worksheet   '// 시트(Sheet)를 넣을 변수
    Dim lookFor As Range
    Dim table_array As Range
    Dim varResult As Variant
    Dim table_array_col As Integer
    Dim lookFor_col As Integer
    Dim oldT As Single  '// 코드 시작시점 넣을 변수
   
   
    oldT = Timer()
    Set sht1 = Sheets("Main")   '// Main 워크시트는 현재 시트
    Set sht2 = Sheets("FileList")   '// FileList 워크시트는 데이터가 있는 Target 시트
    sht1.Select     '// 작업의 실수를 방지하기 위해 해당 시트 선택
   
    Set lookFor = Range([G2], Cells(Rows.Count, "G").End(3))
'    Set table_array = Range("F7:H21")  '// 같은 Sheet 에 있는 테이블을 지정할 때
    Set table_array = sht2.Range("B2:C" & Cells(Rows.Count, "B").End(3).Row)
      '// 다른 Sheet 에 있는 테이블을 지정할 때
    'Set table_array = Workbooks("Book1.xls").Sheets("Sheet1").Range("F2:Q35602")
      '// 다른 File 에 있는 Sheet 를 지정할 때
   
    table_array_col = 2  '// table_array 에서 몇번째 열의 값을 가져올 것인지 설정
   
    varResult = Application.VLookup(lookFor.Value, table_array, table_array_col, 0)
   
    lookFor_col = -6  '// lookFor.Value 열로부터 몇번째 열인지 지정. 0/1/2/3 순으로 카운트 함
    lookFor.Offset(0, lookFor_col) = varResult
   
     MsgBox "총 " & Format(Timer - oldT, "#0.00  초 소요")
End Sub

위 VBA 코드로 4분만에 결과가 나왔다.

VLOOKUP 함수는 동일 자료가 존재하는 경우 무조건 첫번째 만난 셀의 값을 반환한다. 그러다보니 혹시라도 모를 중복자료가 있는 걸 찾아낼 수 없다는 점 때문에 처음에 사용을 하지 않았었다.

그러나 PC 성능의 문제가 있기는 하지만, 동일 PC에서 속도 차이가 10배 이상 차이가 발생했다.

코드 구조상 반복작업을 엄청나게 해야 하는 FIND VBA 코드이니까 당연한 것이지만....

데이터가 더 많아질 경우에는 FIND VBA 코드로는 결과를 얻는데 더 많은 시간을 요구할 것이다.

리눅스 서버에 자료를 올리고 나서 Join 을 사용해서 해야 할 거 같다.

엑셀에서 SQL 문으로 Join 을 하면 어느 정도 성능이 나올까 궁금하기는 하다.

* MySQL 에서 두개의 테이블을 JOIN 하여 칼럼 업데이트를 한 결과 2초도 안되는 시간에 결과를 돌려줬다.

   엑셀 VBA 로 작업하면 적어도 90 분 이상은 소요되었을 거라고 본다.

자막을 정리하고 나면 자막을 srt 파일로 저장해야 한다. 따라서 자막을 내보내기 하는 기능이 필요하다.

Sub srt_export()
'// 자막파일 텍스트 파일로 내보내기
    Dim r&, i&
    Dim strU As String, fName As String
    Dim FN As Integer

    FN = FreeFile
    If Cells(5, "E") = vbNullString Then
        fName = ThisWorkbook.Path & "\srt_data.srt"
    Else
        fName = Cells(5, "E")
    End If
   
    If Cells(Rows.Count, "A").End(3).Row = 1 Then
        MsgBox "내보낼 자막 데이터가 없습니다"
        Exit Sub
    End If
    Open fName For Output As #FN
        For r = 2 To Cells(Rows.Count, "A").End(3).Row
            strU = Cells(r, 1)
            Print #FN, strU
            i = i + 1
        Next r
    Close #FN   '// 작업을 마치고 파일을 닫는다
    MsgBox i & "행 내보내기 완료"
End Sub

srt 자막을 좀 깔끔하게 정리하려고 만들어고 있는 코드이다.

SE(subtitle edit) 자막툴에서는 제공하는 기능도 있지만 없는 기능도 추가를 해서 만들었다.

두사람의 대화 하이픈 처리하는 것도 추가를 했다. 하지만 영상을 보면서 잘못된 것은 직접 수정해야 할 수도 있다.

Sub srt_error_correct()
'// 자막 오류 수정
    Dim rngC, rngAll As Range
    Dim msg As String                           '// 팝업 메시지 변수
    Dim i, k, n, r, cnt, C, sd, ds As Long
    Dim strU As String
       
    Application.ScreenUpdating = False
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))

    i = 0: k = 0: n = 0: sd = 0: ds = 0   '// 초기값 0
    For r = rngAll.Rows.Count + 1 To 2 Step -1    '// 마지막행부터 위로 올라가면서 삭제처리
'        Cells(r, "A").Select
        If InStr(Cells(r, "A"), "-->") > 0 Then     '// 타임코드 행을 만나면
            If Cells(r + 1, "A") = vbNullString Then    '// 바로 아래 행이 빈줄이면
                If IsNumeric(Cells(r + 2, "A")) Then    '// 그 아랫줄이 행을 나타내는 숫자인가?
                    Range(Cells(r - 1, "A"), Cells(r + 1, "A")).Resize(, 3).Delete
                    r = r - 1   '// 셀이 삭제되므로 1 만 감소시켜야 함
                    sd = sd + 1     '// delete 한 빈자막 숫자 카운트
                Else
                    r = r - 1
                End If
            Else
                r = r - 1
            End If
        Else
            If Left(Cells(r, "A"), 1) = "(" And Right(Cells(r, "A"), 1) = ")" Then
                Cells(r, "A").Resize(, 3).Delete   '// Shift:=xlUp
                i = i + 1
           
            ElseIf Left(Cells(r, "A"), 2) = "-(" And Right(Cells(r, "A"), 1) = ")" Then
                Cells(r, "A").Resize(, 3).Delete      '// Shift:=xlUp
                i = i + 1
           
            ElseIf InStr(Cells(r, "A"), ":") And InStr(Cells(r, "A"), "-->") = 0 Then   '// 사람 구분을 위한 식별자 : 가 들어간 경우
                strU = Trim(Split(Cells(r, "A"), ":")(0))
                If InStr(Cells(r, "A"), "http://") = 0 Then
                    Cells(r, "A") = Trim(Split(Cells(r, "A"), ":")(1))      '// : 가 들어간 오른쪽만 저장(사람 식별자는 지움)
                    k = k + 1
                End If
           
            ElseIf InStr(Cells(r, "A"), "(") Then
                If InStr(Cells(r, "A"), ")") Then
                    Cells(r, "A") = Trim(Split(Cells(r, "A"), "(")(0)) & Trim(Split(Cells(r, "A"), ")")(1))     '// ( 괄호안의 내용은 제외
                    n = n + 1
                End If
       
            ElseIf InStr(Cells(r, "A"), "[") Then
                If InStr(Cells(r, "A"), "]") Then
                    Cells(r, "A") = Trim(Split(Cells(r, "A"), "[")(0)) & Trim(Split(Cells(r, "A"), "]")(1))     '// [ 괄호안의 내용은 제외
                    n = n + 1
                End If
           
            ElseIf Left(Cells(r, "A"), 1) = "-" And Mid(Cells(r, "A"), 1, 2) <> "- " Then   '// - 다음에 공백이 아니면
                Cells(r, "A") = "- " & Mid(Cells(r, "A"), 2, Len(Cells(r, "A")) - 1)    '// - 다음에 공백을 하나 넣어라
                ds = ds + 1
               
            ElseIf Mid(Cells(r, "A"), 1, 2) = "- " Then     '// 윗줄에는 - 가 들어가 있고 아랫줄에는 - 가 없으면
                If Cells(r + 1, "A") <> vbNullString And Left(Cells(r + 1, "A"), 1) <> "-" Then     '// - 가 없으면
                    Cells(r + 1, "A") = "- " & Cells(r + 1, "A")
                    ds = ds + 1
                End If
               
            ElseIf Left(Cells(r, "A"), 1) <> "-" And Mid(Cells(r + 1, "A"), 1, 2) = "- " Then   '// 윗줄 - 가 없고 아랫줄 - 가 있을 경우
                Cells(r, "A") = "- " & Cells(r, "A")
                ds = ds + 1
               
            ElseIf Left(Cells(r, "A"), 1) = "-" And Cells(r + 1, "A") = vbNullString And Cells(r + 2, "A") <> vbNullString Then
                Cells(r, "A") = Trim(Mid(Cells(r, "A"), 2, Len(Cells(r, "A")) - 1))
            End If
        End If
    Next
   
    Set rngAll = Nothing
    cnt = i + k + n + sd + ds
    msg = "청각자막 = " & i & " 개" & vbCr
    msg = msg & "대사 : 있는 것 = " & k & " 개" & vbCr
    msg = msg & "괄호문자 = " & n & " 개" & vbCr
    msg = msg & "빈자막 = " & sd & " 개" & vbCr
    msg = msg & "대쉬처리 = " & ds & " 개" & vbCr
    msg = msg & "총 " & cnt & " 개 자막수정 처리했음" & vbCr
    msg = msg & "총 Line 수 = " & Cells(Rows.Count, "A").End(3).Row - 1
    MsgBox msg
End Sub

srt 자막을 정리하다보면 빈자막을 지우고 정리하고 싶을 때가 있다.

동일한 작업을 몇번 해주면 더이상 할 일이 없을 때가 나온다.

아직 코드를 완벽하게 만들지 못해서 부족한대로 만들고 있다.

Sub blank_subtitle_delete()  '// 빈자막 제거
    Dim rngC, rngAll As Range
    Dim msg As String
    Dim i, r As Long
       
    Application.ScreenUpdating = False
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))

    i = 0
    For r = rngAll.Rows.Count + 1 To 2 Step -1    '// 마지막행부터 위로 올라가면서 삭제처리
        If InStr(Cells(r, "A"), "-->") > 0 Then     '// 타임코드 행을 만나면
            If Cells(r + 1, "A") = vbNullString Then
                If IsNumeric(Cells(r + 2, "A")) Then
                    Range(Cells(r - 1, "A"), Cells(r + 1, "A")).Resize(, 3).Delete
                    r = r - 1   '// 셀이 삭제되므로 1 만 감소시켜야 함
                    i = i + 1
                ElseIf Not IsNumeric(Cells(r + 2, "A")) Then
                    Cells(r + 1, "A").Delete
                    r = r - 1
                    i = i + 1
                End If
            Else
                If Cells(r + 2, "A") = vbNullString Then
                    If Cells(r + 3, "A") = vbNullString Then
                        Cells(r + 3, "A").Delete
                        r = r - 1
                        i = i + 1
                    End If
                End If
            End If
        End If
    Next
   
    Set rngAll = Nothing
    msg = "빈자막 = " & i & " 개" & vbCr
    msg = msg & "총 Line 수 = " & Cells(Rows.Count, "A").End(3).Row - 1
    MsgBox msg
End Sub

UserForm 을 이용하여 만들어서 사용하면 좀 더 편리하다.

여러가지 경우의 수를 IF문으로 라디오버튼과 CommandButton 을 이용해서 하면 편리하다.

그냥 module 할 때에는 좀 지저분하기도 한데 UserForm 으로 만들어서 하면 UserForm 만 백업받아두면 상당히 편리하다.

엑셀의 셀값을 넘길때 알아야 할 사항은

숫자는 uid =" & C.Text & "

문자열은 subject =""" & C.Offset(, 4).Text & """  또는 subject ='" & C.Offset(, 4).Text & "'

strSQL = strSQL & " 이름 Like '%" & T & "%' "

값을 넘기는 따옴표, 이중따옴표를 주의하면 실수를 하지 않는다.

초보자 입장에서는 이 부분의 실수가 가장 크다.

Private Sub CommandButton1_Click()
'// 도구->참조에 Microsoft ActiveX data object Library 2.8를 체크해야 함
    Dim MySQLconn As New ADODB.Connection
    Dim strDBconn As String
    Dim DBtblName As String
    Dim shtName As Variant
   
    Dim server_name As Variant
    Dim user_id As Variant
    Dim DB_pass As Variant
    Dim database_name As Variant

    Dim sSQL As String                '// MySQL Query 문 변수
    Dim i As Long, dbRow As Long, n As Long
   
    Application.ScreenUpdating = False  '// 화면 갱신 정지
    Application.DisplayAlerts = False

    Set shtName = Worksheets("DB_Setting")   '// DB_Setting Sheet 에서 설정한 값을 가져온다
    Set server_name = shtName.Range("A2")     '// IP  설정 값
    Set DB_port = shtName.Range("B2")   '// PORT  설정 값
    Set user_id = shtName.Range("C2")   '// User  설정 값
    Set DB_pass = shtName.Range("D2")   '// PASS  설정 값
    Set database_name = shtName.Range("E2")   '// DB  설정 값

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

    Set MySQLconn = New ADODB.Connection
    strDBconn = "DRIVER={MySQL ODBC 5.1 Driver};SERVER=" & server_name & ";PORT=" & DB_port & ";DATABASE=" & database_name & ";USER=" & user_id & ";PASSWORD=" & DB_pass & ";OPTION=3;"
    MySQLconn.Open strDBconn   '// Open the connection
   
    For Each C In rngAll
        Application.StatusBar = "셀: " & C.Address(0, 0) & " / " & C.Text & " 진행중..."
        If IsNumeric(C) Then    '// 숫자이면
            If OptionButton1.Value = True Then     
                sSQL = "UPDATE data SET is_checking=8 Where uid =" & C.Text & ""
                Range(Cells(C.Row, "A"), Cells(C.Row, "B")).Interior.ColorIndex = 33
            ElseIf OptionButton2.Value = True Then 
                sSQL = "UPDATE data SET is_checking=7 Where uid =" & C.Text & ""
                Range(Cells(C.Row, "A"), Cells(C.Row, "B")).Interior.ColorIndex = 33
            ElseIf OptionButton3.Value = True Then 
                sSQL = "UPDATE data SET is_checking=5 Where uid =" & C.Text & ""
                Range(Cells(C.Row, "A"), Cells(C.Row, "B")).Interior.ColorIndex = 43
            ElseIf OptionButton4.Value = True Then  '
                sSQL = "UPDATE data SET is_checking=0 Where uid =" & C.Text & ""
                Range(Cells(C.Row, "A"), Cells(C.Row, "B")).Interior.ColorIndex = xlNone
            ElseIf OptionButton5.Value = True Then
                sSQL = "UPDATE data SET hidden=1 Where uid =" & C.Text & ""
            ElseIf OptionButton9.Value = True Then
                sSQL = "UPDATE data SET sex=0, role="""" Where uid =" & C.Text & ""
            ElseIf OptionButton10.Value = True Then
                sSQL = "UPDATE data SET hidden=0 Where uid =" & C.Text & ""
            End If
           
            MySQLconn.Execute sSQL
        End If
    Next C

    MySQLconn.Close
    Set MySQLconn = Nothing
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    OptionButton8 = True    '// 최초실행시 정상 기본값
    MsgBox "완료!!", 64, ThisWorkbook.Name
End Sub

본 코드는 VBA 고수인 "하나를하더라도최선을"님이 만들어주신 코드에 필요한 걸 추가해서 작성한 코드다.

파일명이 입력된 셀을 기준으로 그 파일이 어느 폴더에 있는지 전부 찾아주는 것이다.

IIF 함수는 PHP 의 삼항연산자 함수와 동일한 기능이다.

IIF(조건,참,거짓) ← 한줄로 조건과 참, 거짓을 표현하므로 코드가 깔끔해진다.

반복횟수처리할 때 오류를 범한 사항이 있어서 수정했다.

SL(SplitLine) 은 적당하게 하는 것이 속도면에서 유리하다. 너무 작게 하는 것도 작업속도를 현저하게 저하시킨다.

하지만, 간단한 자료의 경우에는 몇만 라인인 경우에도 금방 끝나는 걸로 봐서는 SplitLine 의 문제만은 아닌거 같다는 생각이 들었다.

ThisWorkbook.Save 는 정상적으로 수행이 된다면 굳이 한줄 적용해서 속도를 엄청나게 느려지게 할 필요는 없지만, 에러가 발생해서 무반응의 상태가 지속된다면 조금이라도 시간을 아껴볼 요량으로 추가한 것이다.

에러가 발생하면 강제로 Ctrl + Alt + Delete 를 눌러서 엑셀을 강제종료해야 하는 상황이 될 수도 있다.

에러가 발생했을 때 그 부분에서 처리하지 못해서 다음 진행이 제대로 안되어서 인가 하는 생각이 들었다.

On Error Resume Next 이 한줄이 들어가 있느냐 빠뜨리고 있느냐의 차이에서 오는 것인가 하는 생각이 든다.

아직은 좀 더 경험을 해보고 최적의 방안을 찾아봐야겠다.

Sub PathFind()
    Dim Paths As Variant, fPath$, fName$, openMsg$
    Dim rngC, rngDB As Range
    Dim SL, sRow, eRow As Double
    Dim i, n, r As Double, rcnt%
    Dim Col, T As Single
   
    T = Timer()
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False    '// 화면 업데이트 (일시) 중지
    fPath = "C:\Excel Basics\"
    sRow = Cells(Rows.Count, "A").End(3)(2).Row
    Col = "G"       '// 파일명이 들어있는 열 지정
    SL = 3000    '// 전체행을 모두 범위설정하면 메모리 부족현상으로 속도저하 발생 우려 확인 필요
    rcnt = ((Cells(Rows.Count, Col).End(3).Row - sRow) \ SL) + 1
    Debug.Print "반복횟수 = " & rcnt
    For n = 1 To rcnt
        If (sRow + SL) > Cells(Rows.Count, Col).End(3).Row Then     '// 시작행 + SL 이 마지막행보다 크면
            eRow = Cells(Rows.Count, Col).End(3).Row    '// 마지막 행을
        Else
            eRow = sRow + SL                  '// 마지막 행이 SL 보다 크면
        End If
        Debug.Print "start Row = " & sRow & " || end Row = " & eRow
       
        Set rngDB = Range(Cells(sRow, Col), Cells(eRow, Col))
        For Each rngC In rngDB
            Application.StatusBar = "셀: " & rngC.Address(0, 0) & " / " & rngC.Text & " 진행중..."
            r = rngC.Row

            Files = Empty

            FindFile fPath, rngC.Text
            Cells(r, "A") = Join(Paths, vbLf)
        Next rngC
        Set rngDB = Nothing
        ThisWorkbook.Save   '// 현재까지 작업한 내용을 파일에 저장
        sRow = r + 1  '// 시작행으로 지정
    Next n
    Application.ScreenUpdating = True
    Application.StatusBar = "파일 처리 완료"
    MsgBox "완료!! " & vbLf & vbLf & Format(Timer() - T, "0.00초 걸림"), 64, Now()
End Sub

Function FindFile(fPath$, fName$)
    Dim objFolder, objFso, objFile, objSubFolder
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFso.GetFolder(fPath)
   
    fPath = IIf(Right(fPath, 1) = "\", fPath, fPath & "\")
    If Len(Dir$(fPath & fName)) Then
        Dim n%
        On Error Resume Next
        n = UBound(Files)
        If n Then
            n = n + 1
        Else
            n = 1
            ReDim Files(1 To n)
        End If
        ReDim Preserve Files(1 To n)
        Files(n) = objFolder.Path
        n = 0
    End If

    '// 하위 폴더들을 뒤져가면서 작업을 계속 반복
    For Each objSubFolder In objFolder.SubFolders
        FindFile objSubFolder.Path, fName
    Next
End Function

현재 폴더 또는 지정한 폴더의 모든 파일을 엑셀에다가 뿌려주는 VBA 코드이다.

Option Explicit
Sub CurrentPath_FindFiles()
    Dim FSO As New FileSystemObject
    Dim objFSO, objFolder, objFile As Object
    Dim r%
    Dim fPath, openMsg As String
   
    Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")     '// Create an instance of the FileSystemObject
    openMsg = "파일을 가져올 경로를 직접 지정하려면 Yes를 눌러주세요 " & vbCr & vbCr
    openMsg = openMsg & "현재 경로를 선택하려면 No를 눌러주세요" & vbCr
    openMsg = openMsg & "현재 Path : " & ThisWorkbook.Path + "\"
    If MsgBox(openMsg, vbYesNo) = vbYes Then
        '// [도구] - [참조] 에서 Microsoft Scripting Runtime 라이브러리 체크해야 함
        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
   
    Set objFolder = FSO.GetFolder(fPath)     '// Get the folder object
    Range([A1], Cells(Rows.Count, "A").End(3)).Offset(1).Resize(, 2).ClearContents  '// 결과영역 초기화
    r = 2
    For Each objFile In objFolder.Files
        Cells(r, 1) = Left(objFile.Path, InStrRev(objFile.Path, "\"))
        Cells(r, 2) = objFile.Name
        r = r + 1
    Next objFile
End Sub

이번에는 다른 방식으로 현재 폴더의 파일을 가져오는 VBA 코드이다.

Option Explicit
Sub CurrentPath_FindFiles()
    Dim FSO As New FileSystemObject
    Dim objFSO, objFolder, objFile As Object
    Dim r%, T As Single
    Dim fPath, fName, openMsg, getExt As String
    Dim SaveDir As Range
    Dim sDir As Folder      '// 찾을 폴더 변수 선언
   
    Application.ScreenUpdating = False
    T = Timer()
    Set FSO = CreateObject("Scripting.FileSystemObject")     '// Create an instance of the FileSystemObject
    openMsg = "파일을 가져올 경로를 직접 지정하려면 Yes를 눌러주세요 " & vbCr & vbCr
    openMsg = openMsg & "현재 경로를 선택하려면 No를 눌러주세요" & vbCr
    openMsg = openMsg & "현재 Path : " & ThisWorkbook.Path + "\"
    If MsgBox(openMsg, vbYesNo) = vbYes Then
        '// [도구] - [참조] 에서 Microsoft Scripting Runtime 라이브러리 체크해야 함
        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
   
    Range([A1], Cells(Rows.Count, "A").End(3)).Offset(1).Resize(, 2).ClearContents  '// 결과영역 초기화
    fPath = IIf(Right(fPath, 1) = "\", fPath, fPath & "\")
    getExt = "*.mp3"
    fName = Dir(fPath & getExt)     '// 파일의 존재 여부를 판단하기 위해 Dir 함수를 사용
    If fName <> "" Then
        Do
            Set SaveDir = Cells(Rows.Count, "A").End(3)(2)
            SaveDir.Value = fPath
            SaveDir.Offset(0, 1).Value = fName
            fName = Dir()       '// 검색된 새로운 파일 정보를 fName 변수에 저장
        Loop While fName <> ""
    End If
    MsgBox "완료!! " & vbLf & vbLf & Format(Timer() - T, "0.00초 걸림"), 64, Now()
End Sub

현재폴더파일가져오기.xlsm

VBA 를 배우는 초보 입장에서 어려운 점은 원하는 걸 구현하기 위해서 어떤 IF 조건문을 쉽게 찾아내거나 알아서 로직을 구현할 것인가 하는 점이다.

아래 IF 조건문은 그동안 VBA 를 배우면서 익힌 것들인데 앞으로도 계속 추가를 할 생각이다.

IF 조건문 사용함수만 잘 알아도 코딩 시간이 훨씬 줄어든다.

If IsEmpty(rngC) Then        '// 선택된 셀이 비어있다면

If Not IsEmpty(rngC) Then  '// 각 셀이 빈셀이 아니라면

If InStr(rngC, "http") Then   '// http 가 포함되어 있다면, 즉, 웹주소라면

If WorksheetFunction.CountIf(rngC, "*" & FindText & "*") = 0 Then  '// 찾고자 하는 글자가 있다면

If TypeName(fileNames) = "Boolean" Then Exit Sub    '// 취소 선택 시 매크로 종료

If rngC Like "*[가-힣]*" Then   '// 셀에 한글이 포함되어 있으면

If strName = "False" Then         '//취소(Cancel) 선택 시
    MsgBox "취소(Cancel)하여 중단합니다.", 64, "파일선택 오류"  '//오류메시지 출력
    Exit Sub                             '// 매크로 중단
End If

If (iCol = 1) Or (iCol = 6) Or (iCol = 7) Then  '// 지정된 열일 경우

Counter = InputBox("분할할 행의 수 입력하세요")
If Counter = vbNullString Then Exit Sub           '// 취소 선택시 매크로 중단

If Not IsNumeric(Counter) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우 매크로 중단

If Not IsEmpty(rngC.Value) And IsNumeric(rngC.Value) Then  '// 빈셀이 아니고 숫자이면

If MsgBox("기존 데이터를 지울까요?", vbYesNo, Caption) = vbYes Then Sheets("SEARCH_DATA").Cells.Offset(1).Clear

fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls", , _
"엑셀 파일을 선택", MultiSelect:=False)   '// 엑셀 파일을 선택
If fileName = "False" Then Exit Sub       '// 취소 선택시 매크로 종료

If Len(rgnC) - Len(Replace(rgnC.Value, "-", "")) = 3 Then

    rgnC.Offset(0, 1) = Left(rngC, InStrRev(rngC, "-") - 1)

Else

    rngC.Offset(0, 1) = r

End If

찾고자 하는 파일이 있는 폴더가 여러개인 경우 모두 같은 셀에 표기를 하였는데

한 행에는 디렉토리가 1개씩만 보이도록 처리해야 할 상황이 생겨서 코드를 만들었다.

셀내의줄바꿈분리.xlsm

그래서 자동매크로를 실행해서 줄바꿈 명령어가 Chr(10) 인 것을 확인했다.

행을 추가하거나 삭제하는 것이므로 For 문은 역순으로 시행되도록 해야 한다.

궁금한 사항은 중간 중간에 Debug.Print 문으로 확인해가면서 코드를 완벽하게 테스트를 했다.

Sub 셀내의줄바꿈분리()
    Dim rngC, rngAll As Range
    Dim v, n%, T$
    Dim r, eRow, k As Long
   
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    eRow = Cells(Rows.Count, "B").End(3).Row
    For r = eRow To 2 Step -1
        Set rngC = Cells(r, "A")
        If InStr(rngC, Chr(10)) Then
            v = Split(rngC, Chr(10))        '// Split 으로 분리하여 배열에 저장
            For n = UBound(v) To LBound(v) Step -1      '// 배열 갯수만큼 반복 순환하면서
                If n > 0 Then
                    rngC.Offset(1).EntireRow.Insert
                    rngC.EntireRow.Copy
                    rngC.Offset(1).EntireRow.PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    rngC.Offset(1) = v(n)       '// 얼핏보기에는 rngC.Offset(n) 인줄로 착각했다가 테스트하면서 수정했음
                Else
                    rngC.Offset(n) = v(n)       '// rngC.Offset(0) 는 rngC 를 의미함
                End If
                k = k + 1
            Next n
        End If
    Next r
    Set rngAll = Nothing

    MsgBox k & "행으로 분리 완료"
End Sub

Sheet 를 내보내기를 할 때 기존에 내보낸 내용은 무시하고 새로운 내용을 파일로 내보내고 싶다면 기존에 생성된 파일을 삭제해야 한다.

기존 파일을 삭제하라는 명령어는

Kill 경로 & 파일명

oldName = Split(.Name, ".")(0)      '// 파일의 이름만 추출

라고 한 부분은 파일명에 마침표(.)가 들어간 경우에는 문제가 생길 수도 있다.

이럴 경우에는 oldName = Left(.Name, InStrRev(.Name, ".") - 1) 으로 변경해주면 된다.

즉, Left(파일명,길이) 함수와 InstrRev 함수(식별자 . 를 문자열 끝에서부터 계산하여 위치를 반환)를 사용하면 정확하게 확장자만 제외하고 파일명을 반환한다.

Debug.Print 구문을 사용한 이유는 삭제되는 파일이 뭔지 확인하기 위한 목적이다.

직접 실행창에 삭제되는 파일명이 표시된다.

아래와 같이 If Magbox 기능을 이용하여 파일 삭제 여부를 확인하고 처리하게 할 수도 있다.

            If Dir(newName, vbDirectory) <> Empty Then  '// 파일이 있으면
                If MsgBox(newName & "파일이 있는데 삭제하시겠습니까?", vbYesNo) = vbYes Then
                    Debug.Print newName & " 파일이 있어 삭제하고 생성합니다"
                    Kill newName    '// 기존 파일 삭제
                Else
                    MsgBox "먼저 파일을 확인하고 실행하세요"
                    Exit Sub
                End If
            End If

Option Explicit
Sub EachSheet_Into_SeperateFiles_AsSave()  '// 파일 이름 + sheet 이름으로 저장됨
'//  본 실행문은 Sheet 가 비어있는 것은 내보내기 하지 않음
    Dim wb  As Workbook
    Dim sht As Worksheet
    Dim rngUsed As Range
    Dim i%, n%
    Dim oldName, newName As String

    Application.ScreenUpdating = False
    For Each sht In Worksheets   '// 각 sheet를 순환
        If Not (sht.Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0) = "A1" And sht.Cells(1, 1).Value = "") Then
            With ThisWorkbook
                oldName = Split(.Name, ".")(0)      '// 파일의 이름만 추출
                newName = .Path & "\" & oldName & "-" & sht.Name & ".xlsx" '// 현재 폴더에 새로운 파일명 지정
            End With
   
            If Dir(newName, vbDirectory) <> Empty Then  '// 파일이 있으면
                Debug.Print newName & " 파일이 있어 삭제하고 생성합니다"
                Kill newName    '// 기존 파일 삭제
            End If
            Set rngUsed = sht.Cells    '// sheet의 전 영역을 복사
            Set wb = Workbooks.Add   '// 새 엑셀파일(통합문서)를 열음. 아직 파일로 저장된 것은 아님
            If ActiveWorkbook.Sheets.Count <> 1 Then   '// 새 엑셀파일 sheet 개수 1개만 남길 목적으로 검사
                Application.DisplayAlerts = False        '// 경고창이 뜨지 않도록 설정
                    For i = ActiveWorkbook.Sheets.Count To 2 Step -1  '// 총 sheet 개수부터 시작해서 1개만 남기고 삭제
                    ActiveWorkbook.Sheets(i).Delete
                Next i
                Application.DisplayAlerts = True    '// 경고창이 뜨도록 되돌려 놓음
            End If
                  
            rngUsed.Copy wb.Sheets(1).[A1]
            wb.SaveAs Filename:=newName  '//파일명 저장
            wb.Close
            n = n + 1
        End If
    Next sht

    Application.ScreenUpdating = True

    If n = 0 Then
        MsgBox "내보내기할 시트가 없습니다"
    Else
        MsgBox n & " 개 파일 생성 완료"
    End If
End Sub

파일시트내보내기.xlsm

엑셀 Sheet 를 각각의 파일로 분리하여 저장하고 싶을 때 사용하는 VBA 코드이다.

시트 내보내기 코드를 접한 건 더 초보시절에 접했는데 그때는 어떻게 손을 대야 할지 몰라서 빈시트까지 내보내는 형태로 만들었다.

아래 코드는 테스트를 하면서 확인한 거라 완벽하게 동작한다.

파일시트내보내기.xlsm

Option Explicit     '//변수를 선언하지 않아 발생할 오류를 방지
Sub Save_EachSheet_Into_SeperateFiles()  '// 파일 이름 + sheet 이름으로 저장됨
'//  본 실행문은 Sheet 가 비어있는 것은 내보내기 하지 않음
    Dim wb  As Workbook
    Dim sht As Worksheet
    Dim rngUsed As Range
    Dim i%, n%
    Dim oldName, newName As String

    Application.ScreenUpdating = False
    For Each sht In Worksheets   '// 각 sheet를 순환
        If Not (sht.Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0) = "A1" And sht.Cells(1, 1).Value = "") Then
            With ThisWorkbook
                oldName = Split(.Name, ".")(0)      '// 파일의 이름만 추출
                newName = .Path & "\" & oldName & "-" & sht.Name & ".xlsx" '// 현재 폴더에 새로운 파일명 지정
            End With
   
            If Dir(newName, vbDirectory) = Empty Then  '// 파일이 없으면
                Set rngUsed = sht.Cells    '// sheet의 전 영역을 복사
                Set wb = Workbooks.Add   '// 새 엑셀파일(통합문서)를 열음. 아직 파일로 저장된 것은 아님
                If ActiveWorkbook.Sheets.Count <> 1 Then   '// 새 엑셀파일 sheet 개수 1개만 남길 목적으로 검사
                    Application.DisplayAlerts = False        '// 경고창이 뜨지 않도록 설정
                        For i = ActiveWorkbook.Sheets.Count To 2 Step -1  '// 총 sheet 개수부터 시작해서 1개만 남기고 삭제
                        ActiveWorkbook.Sheets(i).Delete
                    Next i
                    Application.DisplayAlerts = True    '// 경고창이 뜨도록 되돌려 놓음
                End If
                      
                rngUsed.Copy wb.Sheets(1).[A1]
                wb.SaveAs Filename:=newName  '//파일명 저장
                wb.Close
                n = n + 1
            Else
                MsgBox newName & " 파일은 존재하므로 확인해보세요"
            End If
        End If
    Next sht

    Application.ScreenUpdating = True

    If n = 0 Then
        MsgBox "내보내기할 시트가 없습니다"
    Else
        MsgBox n & " 개 파일 생성 완료"
    End If
End Sub

* 활용하실 분은 첨부파일내에 포함된 코드를 복사해서 내보내기할 엑셀파일에 붙여넣기 해서 사용하면 됩니다.

윈도우 폴더에 있는 실제 파일이 삭제되는 VBA 코드이다.

따라서 파일 삭제를 잘못하면 되돌릴 수가 없으므로 다시 한번 확인하는 IF문을 넣었다.

Selection (선택한 셀) 로 처리를 한 이유는 선택한 셀 단위로 하나씩 확인해야지 다중으로 전체를 날리면 안되는 경우를 고려했다.

다중으로 날리려면 약간 손을 봐서 삭제를 하면 된다.

Sub File_Delete()  '// 특정 폴더의 파일 삭제
    Dim rngC, rngAll As Range
    Dim oldName, newName As String
    Dim oldPath, newPath As String
    Dim msg As String
   
    Set rngAll = Range([B2], Cells(Rows.Count, "B").End(3))
   
    For Each rngC In Selection
        oldPath = Cells(rngC.Row, "A")
        oldName = oldPath & "\" & Cells(rngC.Row, "B")
        If Dir(oldName, vbDirectory) = "" Then          '// 파일이나 폴더가 없다면
            Cells(rngC.Row, "C").Value = "파일없음"
        Else
            msg = Cells(rngC.Row, "B") & "파일 삭제가 맞나요?" & vbCr
            msg = msg & "Path : " & Cells(rngC.Row, "A") & vbCr
            msg = msg & Cells(rngC.Row, "I")
            If MsgBox(msg, vbYesNo) = vbYes Then
                On Error Resume Next
                SetAttr oldName, vbNormal       '// 파일 속성을 변경시키고
                Kill oldName                            '// 파일을 삭제하라
                On Error GoTo 0
                Cells(rngC.Row, "C").Value = "Deleted"
            Else
                newPath = "C:\Excel Basics\Delete_Items"
                newName = newPath & "\" & Cells(rngC.Row, "B")
                If MsgBox("삭제대상 폴더로 이동시키겠습니까?", vbYesNo) = vbYes Then
                    If Dir(newName, vbDirectory) = Empty Then
                        Name oldName As newName     '// 같은 파일명으로 이동됨
                        Cells(rngC.Row, "C").Value = "ReMove"
                    Else
                        newName = newPath & "\" & Split(Cells(rngC.Row, "B"), ".")(0) & "__." & Split(Cells(rngC.Row, "B"), ".")(1)
                        Name oldName As newName     '// 다른 파일명으로 이동됨
                        Cells(rngC.Row, "C").Value = "Change_Moved"
                    End If
                End If      '// 삭제대상 폴더로 이동 IF문 종료
            End If      '// 파일삭제 IF문 종료
        End If
    Next rngC
End Sub

윈도우의 특정 폴더로 파일을 전체 Move 하기 위한 것이며, 다른 PC에서 작업한 사항을 반영하기 위해서 이미 Move된 것인지 파악하여 처리하는 코드이다.

Sub files_move()
    Dim rngC, rngAll As Range
    Dim oldName, newName As String
    Dim k%, r%
   
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
   
    For Each rngC In rngAll
        If InStr(Cells(rngC.Row, "A"), "원본") > 0 Then  '// 원본 폴더로 되어 있으면
            Application.StatusBar = rngC.Row & " 행 진행중"
            oldName = Left(Cells(rngC.Row, "A"), Len(Cells(rngC.Row, "A")) - 3) & "\" & Cells(rngC.Row, "B")
            newName = Cells(rngC.Row, "A") & "\" & Cells(rngC.Row, "B")
           
            If Dir(oldName, vbDirectory) = "" Then  '// 파일이 없다면
                If Dir(newName, vbDirectory) <> Empty Then
                    Cells(rngC.Row, "C").Value = "Moved"
                    Cells(rngC.Row, "C").Interior.ColorIndex = 36
                    k = k + 1
                End If
               
            Else
                If Dir(newName, vbDirectory) = Empty Then   '// 원본폴더에 파일이 없다면
                    Name oldName As newName
                    Cells(rngC.Row, "C").Value = "Moved"
                    Cells(rngC.Row, "C").Interior.ColorIndex = 36
                    r = r + 1
                Else
                    k = k + 1
                    Debug.Print rngC.Row & " 행은 이미 Moved 상태입니다"
                End If
            End If
           
        End If
    Next rngC
    Application.StatusBar = r & " 건 Moved  " & k & " Already Moved"
End Sub

윈도우의 폴더를 생성하는 함수는 mkdir 이다.

fPath = "C:\abc\"

If Len(Dir(fPath, vbDirectory)) = 0 Then  MKDir fPath

'// 폴더가 없으면 폴더를 생성하라.

테스트를 해보니 폴더를 2단계까지 없는 것은 생성을 못한다. 에러가 난다.

없는 폴더가 1단계인 것은 바로 생성을 한다.

Sub File_MKDir_Rename()
    Dim rngC, rngAll As Range
    Dim oldName, newName As String
    Dim oldPath, newPath As String
   
    For Each rngC In Selection
        oldPath = Cells(rngC.Row, "A") & "\"
        newPath = Cells(rngC.Row, "A") & "\song\temp\"
        oldName = oldPath & Cells(rngC.Row, "B")
        newName = newPath & Cells(rngC.Row, "B")
       
        If Dir(oldName, vbDirectory) = "" Then  '// 파일이 없다면
            Cells(rngC.Row, "C").Value = "파일없음"
        Else
            If Len(Dir(newPath, vbDirectory)) = 0 Then MkDir newPath
            '// newPath 가 없으면 생성하라
            If Dir(newName, vbDirectory) = Empty Then
                Name oldName As newName
                Cells(rngC.Row, "A") = newPath
                Cells(rngC.Row, "C").Value = "Move"
            Else
                Cells(rngC.Row, "C").Value = "동일파일 존재"
            End If
        End If
    Next rngC
End Sub

위와 같은 폴더생성 코드를 만들면 에러가 발생할 수 있다.

아래와 같이 MKDir 생성하는 코드를 만들어야 문제가 없다.

파일 리스트.xlsm

Sub File_MKDir_Rename()
    Dim rngC, rngAll As Range
    Dim oldName, newName As String
    Dim oldPath, newPath As String
    Dim i%
   
    For Each rngC In Selection
        oldPath = Cells(rngC.Row, "A") & "\"
        newPath = Cells(rngC.Row, "A") & "\song\temp\"
        oldName = oldPath & Cells(rngC.Row, "B")
        newName = newPath & Cells(rngC.Row, "B")
       
        If Dir(oldName, vbDirectory) = "" Then  '// 파일이 없다면
            Cells(rngC.Row, "C").Value = "파일없음"
        Else
            If Len(Dir(newPath, vbDirectory)) = 0 Then  '// 폴더가 없으면 폴더를 생성하라
                Dim PathLoc%: PathLoc = 1   '// inStr 함수는 시작이 1부터 이므로 1 이상의 숫자가 필요
                Debug.Print "Ubound = " & UBound(Split(newPath, "\"))
                For i = 1 To UBound(Split(newPath, "\"))
                    If Dir(Left(newPath, InStr(PathLoc, newPath, "\")), vbDirectory) = Empty Then
                        MkDir Left(newPath, InStr(PathLoc, newPath, "\"))
                    End If
                    PathLoc = InStr(PathLoc, newPath, "\") + 1
       Debug.Print "PathLoc = " & PathLoc & " i = " & i & " " & Left(newPath, InStr(PathLoc, newPath, "\")) & vbCr
                Next i
            End If
            If Dir(newName, vbDirectory) = Empty Then
                Name oldName As newName
                Cells(rngC.Row, "A") = newPath
                Cells(rngC.Row, "C").Value = "Move"
            Else
                Cells(rngC.Row, "C").Value = "동일파일 존재"
            End If
        End If
    Next rngC
End Sub

* MKDir 코드 생성 부분은 http://www.abyul.com/zbxe/110014 참조하였음

부분적으로 일치하는 걸 가져오는 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

Sub 셀에넣기()
    Cells(Rows.Count, "C").End(3)(2) = Application.Caller
End Sub

위와 같이 클릭시 아래로 문구들이 붙는 버튼을 만들었습니다.

여기서 변형으로

중간에 삭제시 빈 공간이 생겼을때

빈공간부터 채워지고 빈공간이 없을때

맨 아래로 이어서 채워지게 할 수는 없을까요?

End(4) 는 위로부터 셀이 아래로 내려가면서 공백이 나오기 바로 전 셀입니다.
End(xlDown).offset(1) = End(4)(2)는 같은 의미입니다.

Sub 셀에넣기()
    If Cells(2, "C").End(4)(2) = vbNullString Then   '// 셀이 비어있으면
        Cells(Rows.Count, "C").End(4)(2) = Application.Caller
    End If
End Sub

엑셀의 셀을 2칸씩 셀병합을 자동으로 하는 VBA 코드이다.

Sub CellMerge()
    Dim r As Long, eRow As Long, n As Long
   
    eRow = Cells(Rows.Count, "A").End(3).Row   '// A열의 마지막행
    Application.DisplayAlerts = False
    With Range("A2:B" & eRow)
        .UnMerge    '// 셀 병합 해제
        For r = 2 To eRow Step 2   '// 2씩 증가
            n = n + 1  '// 순번
            Cells(r, "a").Resize(2).Merge  '// A열 병합
            Cells(r, "a") = n  '// 순번
            Cells(r, "b").Resize(2).Merge   '// B열 병합
        Next
    End With
    Application.DisplayAlerts = True
End Sub

병합된 셀에서 원하는 데이터를 찾아서 가져오는 코드를 만들어봤다.

MergeArea_ex-01.xlsm

Sub Macro()
'// 엑셀에서 Alt + F11 키 누르면 뜨는 창에서 메뉴 [삽입] - [모듈] 선택
'// 이 코드를 붙여넣기
'// F5키를 누르면 실행됨
    Dim rngC As Range
    On Error Resume Next
    For Each rngC In Range([B2], Cells(Rows.Count, "B").End(3)) '// 구간 범위 설정

        If rngC.MergeCells And Not IsEmpty(rngC) Then
            Debug.Print "이름 : " & rngC.Text   '// 직접 실행창(Ctrl + G) 에서 출력되는 내용
            If rngC.Text = "순이" Then   '// 특정셀을 기록해야 하는데 직접 이름을 적어봤음
                MsgBox rngC.Offset(, 1).Offset(1)
            End If
        End If
    Next rngC
End Sub

'// 사용자가 만들어서 사용하는 함수
Function Find_Data(ByVal Name As String) As String
'// 엑셀에서 Alt + F11 키 누르면 뜨는 창에서 메뉴 [삽입] - [모듈] 선택
'// 이 코드를 붙여넣기
    Dim rngC As Range
    On Error Resume Next
    For Each rngC In Range([B2], Cells(Rows.Count, "B").End(3)) '// 구간 범위 설정
        '//B2셀부터 B열의 값이 있는 마지막 열까지
        If rngC.MergeCells And Not IsEmpty(rngC) Then
            Debug.Print "이름 : " & rngC.Text   '// 직접 실행창(Ctrl + G) 에서 출력되는 내용
            If rngC.Text = Name Then
                Find_Data = rngC.Offset(, 1).Offset(1)
            End If
        End If
    Next rngC
End Function
 

참조할 구간범위 및 몇번째 자료를 가져올 것인가를 정하는 것도 한번 작성해봤다.

Function Find_Lookup(ByVal Name As String, ByVal rngDB As Range, ByVal n As Integer) As String
'// 엑셀에서 Alt + F11 키 누르면 뜨는 창에서 메뉴 [삽입] - [모듈] 선택
'// 이 코드를 붙여넣기
    Dim rngC As Range
    On Error Resume Next
    For Each rngC In rngDB   '// 구간 범위 설정
        If rngC.MergeCells And Not IsEmpty(rngC) Then
            If rngC.Text = Name Then
                Find_Lookup = rngC.Offset(, n).Offset(1)
            End If
        End If
    Next rngC
End Function

* 첨부파일에 코드가 다 들어 있습니다.