【VBA로 만들어 보았다】 복수 파일로부터 치아 빠져 데이터를 취득해, 다른 파일에 리스트를 출력한다.

복수 파일로부터 잇몸의 리스트를 취득해, 다른 파일에 출력하는 툴입니다.
환경 제약으로 Python 개발 환경을 구축 할 수 없었고, 오랫동안 VBA로 구축했습니다. 제대로 매치한 것이 그물에 구르지 않았기 때문에 기사로 했습니다.

개발 환경

Windows 10 PRO 1909

Office Home&Business 2016

데이터 취득원의 파일군

　 이러한 파일을 대상으로 데이터를 추출합니다. 이 【메시지】와 【오류/주의 구분】을 취득합니다.　

폴더 내용

파일 내용

【구현】getMsgList.xlsm

출력용 템플릿입니다 (2 시트 구성). VBA는 여기에 구현됩니다.




도구의 참조 설정은 다음과 같습니다.

Microsoft Scripting Runtime

Visual Basic For Applications

OLE automation

Microsoft Excel 16.0 Object Library

Microsoft Office 16.0 Object Library

Sub GetMsgList()

Application.ScreenUpdating = False

'リストの頭の行、
Dim countWorkSheets As Long
countWorkSheets = 2

'初期化
Dim IniRows As Long
IniRows = Sheets(1).Cells(Rows.count, 2).End(xlUp).Row
Sheets(1).Range(Cells(2, 1), Cells(10000, 4)).ClearContents
Worksheets(2).Activate
ActiveSheet.Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(10000, 5)).ClearContents

Sheets(1).Activate
'ファイル操作のオブジェクトを定義する
Dim objFso As FileSystemObject
Set objFso = New FileSystemObject

'相対パスから絶対パスを取得
Dim sPath As String
sPath = objFso.GetAbsolutePathName(ThisWorkbook.path & "\msg\")

'パスが取れてるかどうかをイミディエイトで確認
Debug.Print (sPath)

'ファイル数をカウントする。
Dim FileInt     As Long
FileInt = objFso.GetFolder(sPath).files.count
'ファイルがない場合はエラーにして終わる

If (FileInt < 0) Then
    MsgBox "フォルダがありません。"
    Set objFso = Nothing
    Exit Sub

'ファイルが存在する場合は処理を続行する
End If
    Dim targetFile As file
    '存在するファイル分ループする
    For Each targetFile In objFso.GetFolder(sPath).files
        'ファイルが取れてるかどうかをイミディエイトで確認
        Debug.Print (targetFile)
'        '改めてこのワークシートをアクティベートしておく
'        ThisWorkbook.Activate
        '取得したファイルを開く　以下ブックのwith句
        With Workbooks.Open(targetFile.path, UpdateLink:=False)
            '取得したファイルを開く　以下シートのwith句
            With .Sheets(1)
            '最終行の取得
            Dim LastRow As Long
            LastRow = .Cells(Rows.count, 5).End(xlUp).Row
            Debug.Print (LastRow)
            '縦で検索して、値の先頭から最後まで繰り返す
            Dim countRow As Long
            For countRow = 8 To LastRow
                '空でない場合
                If Not IsEmpty(.Cells(countRow, 5).Value) Then
                    Cells(countWorkSheets, 1) = countWorkSheets - 1
                    Cells(countWorkSheets, 2) = .Cells(countRow, 5)
                    Cells(countWorkSheets, 3) = .Cells(countRow, 6)
                    Cells(countWorkSheets, 4) = Dir(targetFile)
                    countWorkSheets = countWorkSheets + 1
                End If
            Next countRow

        End With
            Application.DisplayAlerts = False
            .Close
            Application.DisplayAlerts = True

    End With

Next targetFile

'一応このシートをアクティベートしておく
Sheets(1).Activate
Dim ThisLastRow As Long
'末行を取得し、rangeでコピーする。
ThisLastRow = Cells(Rows.count, 1).End(xlUp).Row
Debug.Print (ThisLastRow)
'rangeを流用し、コピー
ActiveSheet.Range(Cells(2, 2), Cells(ThisLastRow, 3)).Copy Destination:=Sheets(2).Range("B2")
'アクティベートを変更する。
Worksheets(2).Activate
'重複の削除
ActiveSheet.Range("B1").CurrentRegion.RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes

'ソートを行う。
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Range("A1").CurrentRegion.Sort key1:=ActiveSheet.Range("B2"), key2:=ActiveSheet.Range("C2"), Order1:=xlAscending, Header:=xlYes

'末行を取得しNoを振る。
Dim ListMargeLastRow As Long
ListMargeLastRow = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row
Debug.Print (ListMargeLastRow)
Dim countMargeRow As Long
For countMargeRow = 2 To ListMargeLastRow
    ActiveSheet.Cells(countMargeRow, 1) = countMargeRow - 1
Next countMargeRow

'罫線を引く。
Dim bs As Borders
Set bs = ActiveSheet.Range("A1").CurrentRegion.Borders ' 上下左右の罫線
bs.LineStyle = xlContinuous

Set objFso = Nothing
End Sub

데이터 출력 결과

버튼에 매크로를 등록하고 실행합니다. 그러자 보시다시피 출력할 수 있었습니다. 죄송합니다.

메시지 목록

메시지 목록_중복 삭제