vbscript 复数のExcel的ファイルを1ファイルにまとめる的VBScript

Posted 2021-05-22

Option Explicit

Const msoFileDialogFolderPicker = 4
Const EXTENSION = ".xlsx"

Call MargeSheet

'Excelファイルマージ
Sub MargeSheet()
  Dim scriptPath
  scriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")

  Dim objExcel
  Dim dirPath
  Set objExcel = CreateObject("Excel.Application")
  objExcel.Visible = False
  With objExcel.FileDialog(msoFileDialogFolderPicker)
    .Title = "フォルダを選択してください"
    .InitialFileName = scriptPath
    If .Show Then
      dirPath = .Selecteditems(1)
    Else
      Exit Sub
    End If
  End With

  objExcel.Visible = True

  Dim margeWB, sourceWB

  Dim initSheetCount, sheetCount

  Set margeWB = objExcel.Workbooks.Add
  initSheetCount = margeWB.Worksheets.Count
  sheetCount = initSheetCount
  objExcel.ScreenUpdating = False

  Dim objFSO, objFolder, objFile
  Set objFSO = CreateObject("Scripting.FileSystemObject")

  Dim margeFilePath
  margeFilePath = Replace(scriptPath & "\" & "marge" & EXTENSION, "\\", "\")
  If objFSO.FileExists(margeFilePath) Then
    objFSO.DeleteFile (margeFilePath)
  End If

  Set objFolder = objFSO.GetFolder(dirPath)

  Dim sheet
  objExcel.DisplayAlerts = False
  For Each objFile In objFolder.Files
    If InStr(objFile.Name, "xls") Or InStr(objFile.Name, "xlsx") > 0 Then

        Set sourceWB = objExcel.Workbooks.Open(objFile.Path)

        For Each sheet In sourceWB.Worksheets
            Call sheet.Copy(, margeWB.Worksheets(sheetCount))
            sheetCount = sheetCount + 1
        Next
        sourceWB.Close
    End If
  Next

  If initSheetCount <> sheetCount Then
    Dim i
    For i = initSheetCount To 1 Step -1
        margeWB.Worksheets(i).Delete
    Next
    margeWB.SaveAs (margeFilePath)
  End If

  objExcel.DisplayAlerts = True
  objExcel.ScreenUpdating = True

  objExcel.Quit
  Set objExcel = Nothing

End Sub