フォルダ選択とデータ抽出

フォルダ選択とデータ抽出のサンプルです。

Excelフォーマット＆マクロ

Excelフォーマット

マクロ

Sub dataSelect()
  Application.StatusBar = ""
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  
  StartTime = Now
  
  TargetFolder = PickUpFolder
  If TargetFolder = "" Then
    MsgBox "フォルダ選択してください"
    Exit Sub
  End If
  
  OutPutRowNumber = 4
  outcount = RecursibleFolderSerch(TargetFolder, OutPutRowNumber)
  
  Application.StatusBar = ""
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  
  EndTime = Now
  
  TimeDiff = TimeDiffEdit(StartTime, EndTime)
  MsgBox "完了：" & TimeDiff & Chr(13) & "件数：" & outcount
  
End Sub


Function PickUpFolder()
  Application.StatusBar = ""
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      PickUpFolder = .SelectedItems(1)
    End If
  End With

  Application.StatusBar = ""
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

End Function


Function RecursibleFolderSerch(TargetFolder, OutPutRowNumber)

  Application.StatusBar = ""
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  For Each SerchFolders In FSO.getfolder(TargetFolder).SubFolders
    DoEvents
      Call RecursibleFolderSerch(TargetFolder.Path, OutPutRowNumber)
  Next SerchFolders

  Dim i As Long
  Dim lineNumber As Long
  
  Range(ThisWorkbook.Sheets("一覧").Cells(2, 1), ThisWorkbook.Sheets("一覧").Cells(100, 10)).ClearContents
  
  For Each SearchFiles In FSO.getfolder(TargetFolder).Files
    DoEvents
       If SearchFiles.Type Like "*Excel*" Then
         On Error Resume Next
         Application.DisplayAlerts = True
         
         If SearchFiles.Name <> "XXXXXX" Then
         
           Set TargetWorkbook = Workbooks.Open(Filename:=SearchFiles, ReadOnly:=True)
           Application.DisplayAlerts = True
           If Err.Number <> 0 Then
             ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 1) = Err.Number & ":" & Err.Discription
           End If
         
         For Each SheetObject In TargetWorkbook.Worksheets
         
            For i = 3 To 40
              If SheetObject.Cells(i, 7) = "" Then
                Exit For
              End If
              
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 1) = lineNumber
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 2) = SearchFiles
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 3) = TargetWorkbook.Name
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 4) = SheetObject.Name
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 5) = SheetObject.PageSetup.Pages.Count
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 6) = SheetObject.Cells(i, 3)
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 7) = SheetObject.Cells(i, 4)
              ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 8) = SheetObject.Cells(i, 5)
              
              OutPutRowNumber = OutPutRowNumber + 1
              lineNumber = lineNumber + 1
            Next i
          Next SheetObject
  
  
          Application.DisplayAlerts = False
          On Error Resume Next
          TargetWorkbook.Close
          If Err.Number <> 0 Then
             ThisWorkbook.Sheets("一覧").Cells(OutPutRowNumber, 1) = Err.Number & ":" & Err.Discription
          End If
          Application.DisplayAlerts = True
          On Error GoTo 0
  
        End If

    End If
  Next SearchFiles

  Application.StatusBar = ""
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

  RecursibleFolderSerch = lineNumber - 1

End Function


Function TimeDiffEdit(StartDate, EndDate)

  'YYYYMMDD HH:MM:SS
   ResultDiff = DateDiff("s", StartDate, EndDate)
   DiffH = ResultDiff \ (60 * 60)
   DiffM = ResultDiff \ 60
   DiffS = ResultDiff Mod 60
   TimeDiff = DiffH & "h" & DiffM & "m" & DiffS & "s"
   TimeDiffEdit = TimeDiff
   Application.StatusBar = TimeDiff

End Function

検証

フォルダ選択対象の任意フォルダに以下のテスト用入力ファイルを格納する。

テスト用入力ファイル