フォルダ内の全ファイルの全シートを一枚のシートに統合する

Visual Basic for Applications
Sub Macro()
  Dim FileName(100) '固定長配列の場合。インデックス番号は目的に合わせる。
  Dim ObjNetWork As Object
  Dim GetUserName As String
  Dim FilePath As String
  Dim File
  Dim iii As Integer
  Dim Sheet As Integer
  Dim rrr As Integer
  Dim ImportBook As Workbook
  Dim SheetIndex As Integer
  Dim EndRow As Integer
  Dim EndCol As Integer
  Dim AddedWord As String
  Dim FolderName As String
  Dim FileSavePathFolder As String
  AddedWord = "AddedWord"
  FolderName = "\Desktop\ExampleFolder\"
  Erase FileName
  Set ObjNetWork = CreateObject("WScript.Network")
    GetUserName = ObjNetWork.UserName
  Set ObjNetWork = Nothing
  FilePath = "C:\Users\" & GetUserName & FolderName
  File = Dir(FilePath & "*.*", vbNormal) 'FilePath先フォルダ内の全ファイルを対象。
  iii = 1
  Do While File <> ""
    FileName(iii) = File
    File = Dir() 'Dir関数の引数は空欄にして次のファイル名を取得。
    iii = iii + 1
  Loop
  Sheet = 1 '一例
  rrr = 1
  ThisWorkbook.Activate
  Worksheets(Sheet).Activate
  Cells.Select
  Selection.ClearContents
  ThisWorkbook.Sheets(Sheet).Columns(1).Select '左端列の書式を日付表示に。
  Selection.NumberFormatLocal = "yyyy/m/d"
  Application.DisplayAlerts = False
    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
          EndRow = Worksheets(SheetIndex).Cells(1, 1).End(xlDown).row
          EndCol = Worksheets(SheetIndex).Cells(1, 1).End(xlToRight).Column
          Range(Cells(1, 1), Cells(EndRow, EndCol)).Select
          Selection.Copy
          ThisWorkbook.Activate
          Worksheets(Sheet).Cells(rrr, 1).Select
          Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
          ImportBook.Close
          rrr = rrr + EndRow
          DoEvents
        Next
      End If
    Next iii
  Application.DisplayAlerts = True
  EndRow = Worksheets(Sheet).Cells(1, 1).End(xlDown).row
  EndCol = Worksheets(Sheet).Cells(1, 1).End(xlToRight).Column
  For ccc = 2 To EndCol
    Worksheets(Sheet).Cells(1, ccc) = Worksheets(Sheet).Cells(1, ccc) & AddedWord
  Next ccc
  For rrr = 2 To EndRow
    If IsDate(Worksheets(Sheet).Cells(rrr, 1)) = False Then
      Rows(rrr).Select
      Selection.Delete Shift:=xlUp
      rrr = rrr - 1
      EndRow = EndRow - 1
    End If
    If rrr + 1 > EndRow Then
      Exit For
    End If
  Next rrr
  ThisWorkbook.Save
  FileSavePathFolder = "C:\Users\" & GetUserName & "\Desktop\DataFolder\"
  ThisWorkbook.SaveAs FileName:=FileSavePathFolder & ThisWorkbook.Name, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
  ThisWorkbook.Close
End Sub