LoginSignup
1
2

More than 3 years have passed since last update.

VBAでフォルダ再帰読み込んで、EXCELファイルを一つ読み込んでツール

Last updated at Posted at 2017-08-18

機能仕様:1、フォルダ選択
     2、フォルダ再帰読み込み
     3、フォルダ配下全部ファイル読み込み、処理(自分追加)、TXTログファイルをローカルに出力

' シートに追加された処理開始ボタン
'''Private Sub btn_Generate_Click()

If Len(inputFileFolder.Text) = 0 Then
    Call MsgBox("入力フォルダを入力してください。", vbOKOnly + vbCritical)
    Exit Sub
End If

Call mainPross(inputFileFolder.Text)

End Sub
' シートに追加されたファイル選択ボタン
Private Sub CommandButton1_Click()

Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = inputFileFolder.Text
If Not Application.FileDialog(msoFileDialogFolderPicker).Show Then Exit Sub
inputFileFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

End Sub

※シートにファイルパスを表示用のTEXTBOX追加必要、NAMEはinputFileFolder

モジュールを新規して、下記のソースを書き込み。
Option Explicit

Dim outSheet As Worksheet
Dim inputFileFolder As String
Dim path As String
Dim fileExFlg As Boolean
Dim SaveDir As String

Public Sub mainPross(inputFileFolderP As String)
Windows.Application.ScreenUpdating = False

SaveDir = "C:\log\"

' Set outSheet = ActiveSheet

inputFileFolder = inputFileFolderP
Call ExecEachFolder(inputFileFolder, "**")

End Sub

’入力ディレクトリ再帰して、全部ファイルを繰り返す。
Public Function ExecEachFolder(folderPath As String, kaku As String)

Application.ScreenUpdating = False
Dim FSO As New FileSystemObject

' フォルダ内のファイルを処理する
Dim fe As FILE
For Each fe In FSO.GetFolder(folderPath).Files
    Dim folderNm As String
    folderNm = Split(folderPath, "\")(UBound(Split(folderPath, "\")))
        Dim fp As String: fp = fe.path
        Dim en As String: en = LCase(FSO.GetExtensionName(fp))

      ’ファイル存在の場合、ファイルをOPENして、処理を行う
doBlogic fe.path
Set fe = Nothing
Next

' サブフォルダに再帰的に検索する
Dim fr As Folder
For Each fr In FSO.GetFolder(folderPath).SubFolders
    Call ExecEachFolder(fr.path, kaku)
    Set fr = Nothing
Next

Set FSO = Nothing

a1: Exit Function
End Function

’ファイルをOPENして、自分の業務処理ロジックを書く
Public Function doBlogic(filepath As String)
Dim myBook As Workbook
Dim mySheet As Worksheet
On Error GoTo 1

Dim c
For Each c In Range("k7" & ":" & "k" & Selection.End(xlDown).Row)
   '業務処理(自分追加)
   'ログ出力
   WriteLog c.value
Next c

1:
End Function

' ログ→TXTファイル出力
Sub WriteLog(msg As String)
Dim FSO As Object, LOG As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''ログファイルがなければ作ります
If dir(SaveDir, vbDirectory) = "" Then
MkDir SaveDir
End If
If FSO.FileExists("C:\log\SuccessReport.log") = False Then
FSO.CreateTextFile "C:\log\SuccessReport.log"
End If
''追記で開きます
Set LOG = FSO.OpenTextFile("C:\log\SuccessReport.log", 8)
''日時+タブ+メッセージを書き込みます
LOG.WriteLine Now & vbTab & msg
Set LOG = Nothing
Set FSO = Nothing
End Sub

1
2
1

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
1
2