728x90

Pivot 을 엑셀에서 일일이 매번 지정하려니까 너무 귀찮아서 피벗 VBA 를 아예 만들었다.

어떻게 만드는지 감이 오지 않으면 매크로를 실행해서 만들어진 코드를 분석하면 쉽게 이해할 수 있다.


Sub pivot_make()
    Dim endRow As Long
    Dim CurrentPosition
    Dim C As Range
    Dim rngAll As Range
    Dim wSheet As Worksheet
    Dim wkSht As Worksheet

    On Error Resume Next
    Set wkSht = ThisWorkbook.Worksheets("B_Sheet")
    If Err.Number = 0 Then
        ' Application.DisplayAlerts = False
        ' Worksheets("B_Sheet").Delete
        ' Application.DisplayAlerts = True
    Else
    Worksheets("A_Sheet").Activate
    Worksheets("A_Sheet").Copy after:=Worksheets("A_Sheet")
    ActiveSheet.Name = "B_Sheet"
    End If

    Sheets("B_Sheet").Select
    endRow = Cells(Rows.Count, "A").End(3).Row '// 셀의 마지막 위치가 계속 변하므로

    Cells(1, 1).Select
    If Cells(3, 1) <> "등록일" Then
        Selection.EntireRow.Insert
        Selection.EntireRow.Insert
    End If
    Cells(3, 1).Select
    ActiveSheet.AutoFilterMode = False
    If ActiveSheet.AutoFilterMode = False Then
        Selection.AutoFilter
    End If
    Cells(3, "C").Select

    ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
    Range("C3:C" & endRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveCell.Select
    Cells(3, "C").Select

    '###### 분류 작업 #######
    Set rngAll = Range([C3], Cells(Rows.Count, "C").End(3))

    Application.ScreenUpdating = False
    rngAll.Replace "회사", vbNullString
    rngAll.Offset(0, 1).Replace "기술부", vbNullString

    '##### 피벗테이블 생성 #####
    Sheets("B_Sheet").Select

    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Pivot_New").Delete '// 기존 피벗테이블 삭제
    Sheets.Add(after:=Sheets(8)).Name = "Pivot_New" '새로운 피벗시트를 생성

    Set rngData = Sheets("B_Sheet").Range("A3").CurrentRegion
    Set rngB = ActiveWorkbook.Worksheets("Pivot_New").Range("A3")

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData, _
    Version:=xlPivotTableVersion14).CreatePivotTable TableDestination:=rngB, _
    TableName:="PVR", DefaultVersion:=xlPivotTableVersion14

    '// 보고서 필터
    With ActiveSheet.PivotTables("PVR").PivotFields("부서")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PVR").PivotFields("지역")
        .Orientation = xlPageField
        .Position = 2
    End With

    '// X축
    With ActiveSheet.PivotTables("PVR").PivotFields("분류")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PVR").PivotFields("고객")
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables("PVR").PivotFields("분류").LayoutForm = xlTabular
    ActiveSheet.PivotTables("PVR").PivotFields("고객").LayoutForm = xlTabular

    '// Y축
    With ActiveSheet.PivotTables("PVR").PivotFields("팀")
        .Orientation = xlColumnField
        .Position = 1
    End With

    '// 화면에 표시될 값(결과)
    ActiveSheet.PivotTables("PVR").AddDataField ActiveSheet.PivotTables( _
    "PVR").PivotFields("고객수"), "합계 : 고객수", xlSum

    '// 화면에서 보이지 않게 처리
    ActiveSheet.PivotTables("PVR").PivotFields("지역").CurrentPage = "(All)"
    With ActiveSheet.PivotTables("PVR").PivotFields("지역")
        .PivotItems("서울").Visible = False
        .PivotItems("대구").Visible = False
        .PivotItems("부산").Visible = False
        .PivotItems("전남").Visible = False
        .PivotItems("전북").Visible = False
        .PivotItems("충남").Visible = False
        .PivotItems("충북").Visible = False
        .PivotItems("제주").Visible = False
        .PivotItems("강원").Visible = False
    End With

    ActiveSheet.PivotTables("PVR").PivotFields("담당").EnableMultiplePageItems = True

    MsgBox "피벗 생성완료"
End Sub



블로그 이미지

Link2Me

,
728x90

Httprequest Header 정보를 만들기 위해 작성한 코드이다.

불필요한 헤더 정보도 있지만 그건 작성하면서 수정하면 된다.


Sub httprequest_header()
    Dim rngC As Range
    Dim rngAll As Range
    Dim tmp As Integer
   
    Application.ScreenUpdating = False
    Set rngAll = Range([C3], [C3].End(4))
   
    For Each rngC In rngAll
        tmp = InStr(rngC, ":")
        If tmp > 0 Then
            If Left(rngC, tmp - 1) = "User-Agent" Then
                rngC.Offset(0, -2) = "request.UserAgent" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Accept-Language" Then
                rngC.Offset(0, -2) = "request.AcceptLanguage" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Accept-Encoding" Then
                rngC.Offset(0, -2) = "request.AcceptEncoding" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Content-Type" Then
                rngC.Offset(0, -2) = "request.ContentType" & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            ElseIf Left(rngC, tmp - 1) = "Content-Length" Then
                rngC.Offset(0, -2) = "request.ContentLength=sendData.Length;"
            ElseIf InStr(rngC, "keep-alive") > 0 Then
                rngC.Offset(0, -2) = "request.KeepAlive=true;"
            Else
                rngC.Offset(0, -2) = "request." & Left(rngC, tmp - 1) & "=""" & Trim(Mid(rngC, tmp + 1)) & """" & ";"
            End If
        Else
            rngC.Offset(0, -2) = rngC
        End If
    Next rngC
End Sub

블로그 이미지

Link2Me

,
728x90

자막 정리를 좀 하다보니 바로 위아래 셀 병합을 해야 하는 경우와

한글과 영문이 쌍으로 되어 있어서 한행 아래것과 셀병합을 해야 하는 경우가 있다.


현재 행과 아래행을 병합할 때

Sub Cell_Merge()    '// 위아래 셀 병합
    Dim r&, h&, C As Range
    Set C = Selection
    If C.Count < 2 Then Exit Sub
    If C.Columns.Count > 1 Then MsgBox "열은 합칠 수 없습니다.", 16, "규정위반": Exit Sub
    
    With Selection
        h = .Rows.Count - 1
        For r = 1 To h Step 1
             .Cells(1) = .Cells(1) & " " & .Cells(r + 1)
        Next
        .Cells(2).Resize(h).Delete Shift:=xlUp
    End With
    ActiveCell.Select
End Sub


현재 행과 한칸 아래 행을 병합할 때

Sub subtitle_merge()    '// 한칸 아래셀과 병합
    Dim r&, h&
    With Selection.Resize(, 1)
        If .Rows.Count Mod 2 = 0 Then
            h = .Rows.Count - 2
            If h < 1 Then MsgBox "최소 4개행을 선택해야 합니다", 16, "규정위반": Exit Sub
            For r = 1 To h Step 2
                .Cells(1) = .Cells(1) & " " & .Cells(r + 2)
                .Cells(2) = .Cells(2) & " " & .Cells(r + 3)
            Next
            .Cells(3).Resize(h).Delete Shift:=xlUp
        Else
            MsgBox "홀수행 선택은 안됩니다", 16, "규정위반": Exit Sub
        End If
    End With
    ActiveCell.Select
End Sub

블로그 이미지

Link2Me

,
728x90

자막에서 두사람의 대화인 경우 대쉬(-)를 넣어서 구분되어 있다.

-But if you just... -Rapunzel, we're done talking about this.
-그렇지만 만약… -라푼젤, 이제 이 이야긴 그만하자
-Trust me,... -Rapunzel.
-믿어주세요 전… -라푼젤
-...I know what I'm -Rapunzel.
-알아요 전… -라푼젤
-Oh, come on. -Enough with the lights, Rapunzel.
-제발요 엄마 -너에게 다른 인생이란 없어 라푼젤


이런 자막인 경우에 VBA 를 이용하여 분리 저장을 해봤다.

내가 잘 몰라서 그런지 몰라도 위에서 부터 아래로 For 문을 돌리면 끝까지 처리가 안된다.

그래서 맨 아래줄부터 위로 처리하는 로직으로 구현을 하고 테스트를 해봤다.


자막에 - 가 들어가 있는데 1개만 들어간 경우가 있다. 이 경우에는 - 를 제거해주고

- 가 두개 들어간 경우에는 개수를 먼저 표시한 다음에

자막 대사를 분리 저장하는 로직으로 구현했다.


Sub dash_check()    '// 대쉬가 들어간 것만 표시
    Dim r&, sRow&, eRow&, k&, j&, v
    Application.ScreenUpdating = False
    sRow = 2
    eRow = Cells(Rows.Count, "A").End(3).Row
    For r = sRow To eRow Step 1
        On Error Resume Next
        If InStr(Cells(r, 1), "-") Then     '// 셀에 대쉬(-)가 포함되어 있으면
            v = Split(Cells(r, 1), "-")     '// Split 함수를 이용하여 배열로 저장
            If UBound(v) = 1 Then       '// 배열의 개수를 파악하여 1개, 즉 대쉬(-)가 1개만 들어간 경우이면
                If Left(Cells(r, 1), 1) = "-" Then  '// 셀의 첫번째가 대쉬(-) 이면
                    Cells(r, 1) = Trim(Mid(Cells(r, 1), 2, Len(Cells(r, 1))))   '// 두번째 이후의 값을 다시 셀에 저장하라
                End If
            Else
                Cells(r, "D") = UBound(v)
                j = j + 1
            End If
        Else
            Cells(r, "D") = vbNullString
        End If
    Next r
    MsgBox "총 " & k + j & "개 표시  " & j & "개 " & k & "개"
End Sub

Sub subtitle_cellsplit()
'// 대쉬(-)가 2개 들어간 자막을 분리하여 저장 처리
'// 대쉬(-)가 들어간 자막은 아래부터 위로 처리를 해야 제대로 저장됨
    Dim r&, sRow&, eRow&, k&, j&, v, ss
    Application.ScreenUpdating = False
    sRow = 2
    eRow = Cells(Rows.Count, "A").End(3).Row
    For r = eRow To sRow Step -1
        If Cells(r, 4) = 2 And InStr(Cells(r, 1), "-") And Cells(r - 1, 4) = 2 And InStr(Cells(r - 1, 1), "-") Then
            ss = Split(Cells(r - 1, 1), "-")
            v = Split(Cells(r, 1), "-")
            Cells(r - 1, 1).Value = Trim(ss(1))
            Cells(r - 1, 1).Offset(2).EntireRow.Insert
            Cells(r - 1, 1).Offset(2).Value = Trim(ss(2))
            Cells(r, 1).Value = Trim(v(1))
            Cells(r, 1).Offset(2).EntireRow.Insert
            Cells(r, 1).Offset(2).Value = Trim(v(2))
            r = r - 1
        End If
            k = k + 1
    Next r
    MsgBox "총 " & k & "번 반복"
End Sub






블로그 이미지

Link2Me

,
728x90

자막을 정리할 때 필요한 코드.


Option Explicit
Sub Subtitle_delete()
    If Selection.Count > 1 Then
'        Debug.Print Selection.Count
        Selection.Delete Shift:=xlUp
    Else
        If MsgBox("1개의 셀인데 삭제하겠습니까?", vbYesNo) = vbYes Then
            Selection.Delete Shift:=xlUp
        End If
    End If
End Sub

Sub Subtitle_merge()
    Dim r As Long, h As Long
    With Selection.Resize(, 1)
        h = .Rows.Count - 2
        Debug.Print h
        If h < 1 Then Exit Sub
        For r = 1 To h Step 2
            .Cells(1) = .Cells(1) & " " & .Cells(r + 2)
            .Cells(2) = .Cells(2) & " " & .Cells(r + 3)
        Next
        .Cells(3).Resize(h).Delete Shift:=xlUp
    End With
End Sub

Sub Subtitle_Split()
    Dim rngC As Range, r As Long, c As Long, S As String, v
   
    Columns("A:B").NumberFormat = "@"      '// A:B열을 텍스트 서식으로
    If Cells(Rows.Count, 1).End(3).Row > 1 Then
        Range("b1:b" & Cells(Rows.Count, "B").End(3).Row).Offset(1).ClearContents
    Else
        MsgBox "정리할 자막이 없습니다" & vbCr & "자막부터 복사하세요"
        Exit Sub
    End If
    r = 1
    For Each rngC In Range("a2:a" & Cells(Rows.Count, 1).End(3).Row)
'        Debug.Print "현재 행 = " & rngC.Row
        If Left$(rngC, 2) = "- " And InStrRev(rngC, "- ") > 1 Then
            r = r + 1
            v = Split(rngC, "- ")
            On Error Resume Next
            Cells(r, 2) = v(1)
            S = S & vbLf & v(2)
'            Debug.Print "s 값 : " & s
        Else
            If S <> "" Then SplitTextAddLine r, S
            r = r + 1
            Cells(r, 2) = rngC
        End If
    Next rngC
  
    If S <> "" Then SplitTextAddLine r, S
   
    MsgBox "A열에서 복사 완료"
End Sub

Sub SplitTextAddLine(r, S)
    Dim v, c As Long
    v = Split(S, vbLf)
    For c = 1 To UBound(v)
        r = r + 1
        Cells(r, 2) = v(c)
    Next
    S = ""
End Sub


블로그 이미지

Link2Me

,
728x90

같은 셀에서 줄바꿈(vbLf) 되어 있는 셀내에서 중복이 발생한 것은 제거를 하는 VBA 코드다.


Sub RemoveDuplicate_InCell()
    Dim rngC As Range, Dat As Variant, X As New Collection
    Dim tmp As String, i&
    On Error Resume Next
    For Each rngC In Range([A2], Cells(Rows.Count, "A").End(3)).SpecialCells(2)
        Dat = Split(rngC, vbLf)
        Set X = Nothing
        For i = 0 To UBound(Dat)
            X.Add rngC.Value, CStr(Dat(i))    '// 중복된 데이터는 저장하지 마라
            If Err.Number <> 457 Then    '// 만일 에러가 발생하지 않았으면
                If i = 0 Then
                    tmp = Dat(i)
                Else
                    tmp = tmp & vbLf & Dat(i)
                End If
            End If
            Err.Clear
        Next i
        rngC.Offset(, 1) = tmp
        tmp = vbNullString      '// 셀이 변경될 때 임시변수 초기화
    Next rngC
End Sub

블로그 이미지

Link2Me

,
728x90

서버에 자료가 있는지 SQL 문 조회를 하여 가져온 결과를 화면에 뿌릴때 구현하는 로직이다.

핵심사항만 적어둔다. 나머지 사항은 다른 게시물을 참조하면 된다.


        If RS.EOF Then
            DoEvents
        Else
            RS.MoveFirst  '// Move to the first record
             For i = 1 To RS.RecordCount  '// recordset의  필드 개수만큼 반복
                For n = 1 To RS.Fields.Count
                    If RS.Fields(n - 1) > 0 Then Cells(C.Row, n + 3) = "중복"   '// 표시하고 싶은 열에 중복 표시
                Next n
                RS.MoveNext
            Next i
        End If
        RS.Close    '//Close connection again

블로그 이미지

Link2Me

,
728x90

어제 완전 삽질을 했다.

데이터 갯수 : 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 분 이상은 소요되었을 거라고 본다.


블로그 이미지

Link2Me

,
728x90

자막을 정리하고 나면 자막을 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

블로그 이미지

Link2Me

,
728x90

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

블로그 이미지

Link2Me

,
728x90

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

블로그 이미지

Link2Me

,
728x90

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


블로그 이미지

Link2Me

,
728x90

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

블로그 이미지

Link2Me

,
728x90

현재 폴더 또는 지정한 폴더의 모든 파일을 엑셀에다가 뿌려주는 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



블로그 이미지

Link2Me

,
728x90

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


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

셀내의줄바꿈분리.xlsm


처음에는 vbNewLine 인가 하고 테스트를 해보니 딱 2개로만 분리가 되고 줄바꿈이 3개 4개인 것은 인식을 못하는 걸 확인했다.

그래서 자동매크로를 실행해서 줄바꿈 명령어가 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

블로그 이미지

Link2Me

,
728x90

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



블로그 이미지

Link2Me

,
728x90

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

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


블로그 이미지

Link2Me

,
728x90

윈도우 폴더에 있는 실제 파일이 삭제되는 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

블로그 이미지

Link2Me

,
728x90

윈도우의 특정 폴더로 파일을 전체 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

블로그 이미지

Link2Me

,
728x90

윈도우의 폴더를 생성하는 함수는 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 참조하였음


블로그 이미지

Link2Me

,