フォルダ内のファイルをインポート

Visual Basic for Applications

Sub Macro()
  Dim ObjNetWork As Object
  Dim GetUserName As String
  Dim iii As Integer
  Dim cnt As Integer
  Dim DeleteSheetIndex As Integer
  Dim FolderName As String
  Dim FilePath As String
  Dim File
  Dim FileName(100) '固定長配列の場合。インデックス番号は目的に合わせる。
  Dim ImportBook As Workbook
  Dim SheetIndex As Integer
  Dim tmp As String
  Set ObjNetWork = CreateObject("WScript.Network")
    GetUserName = ObjNetWork.UserName
  Set ObjNetWork = Nothing
  iii = 1
  cnt = 1
  DeleteSheetIndex = 1 '一例。シートインデックス = 1 + 1 = 2 以降のシートを全て削除する場合
  FolderName = "ExampleFolder"
  FilePath = "C:\Users\" & GetUserName & "\Desktop\" & FolderName & "\" '一例。
  File = Dir(FilePath & "*.*", vbNormal) 'FilePath先フォルダ内の全ファイルを対象。
  Do While File <> ""
    FileName(iii) = File
    File = Dir() 'Dir関数の引数は空欄にして次のファイル名を取得。
    iii = iii + 1
  Loop
  Application.DisplayAlerts = False
    For iii = DeleteSheetIndex + cnt To ThisWorkbook.Worksheets.Count
      ThisWorkbook.Sheets(DeleteSheetIndex + cnt).Delete
    Next iii
    For iii = 1 To UBound(FileName)
      If FileName(iii) = "" Then
        Exit For
      Else
        Set ImportBook = Workbooks.Open(FilePath & FileName(iii))
        For SheetIndex = 1 To ImportBook.Sheets.Count
          Windows(ThisWorkbook.Name).Activate
          Sheets.Add after:=Sheets(DeleteSheetIndex + cnt - 1)
          ImportBook.Sheets(SheetIndex).Cells.Copy ThisWorkbook.Sheets(DeleteSheetIndex + cnt).Cells
          tmp = InStr(FileName(iii), ".")
          tmp = Application.WorksheetFunction.Min(tmp - 1, 15) '一例。インポートファイルのファイル名の左から最大15文字分をインポートしたシート名とする。
          tmp = Left(FileName(iii), tmp)
          ThisWorkbook.Sheets(DeleteSheetIndex + cnt).Name = (DeleteSheetIndex + cnt) & "." & tmp & "." & SheetIndex
          ThisWorkbook.Sheets(DeleteSheetIndex + cnt).Columns(1).Select '左端列の書式を日付表示に。
          Selection.NumberFormatLocal = "yyyy/m/d"
          cnt = cnt + 1
        Next
        ImportBook.Close
      End If
    Next iii
  Application.DisplayAlerts = True
  Worksheets(1).Select
  Cells(1, 1).Select
End Sub