VBSで業務効率化。Excelをシート毎に分割保存するツールのご紹介。

おはようございます。
くまおです。

本日のテーマは業務効率化。
Excelのシートをシート毎にシートの名前でExcelに保存するツールのご紹介です。

くまお

纏めて作成したブック内のシートを個別に分割保存する時にご活用ください！

VBSとは
Excelシート分割保存ツール

VBSとは

VBSについては以前の記事で簡単に説明していますので興味がある方は参考にしてみてください。

VBSで簡単業務改善。新規フォルダー一括作成ツールのご紹介。

おはようございます。くまおです。本日のテーマは業務効率化。誰でも簡単に作成できるVBSのツールのご紹介です。くまおWin...

Excelシート分割保存ツール

『このExcel、シートがたくさんあるから開くの遅いし、参照するのに時間がかかるんだよな～。誰かシート毎に分割保存してくれれば嬉しいのにな～。』というお客様のお悩みを解決するために、こっそり作成してみました。それではツールのご紹介です。

注意点

ファイル名に使用できない記号（”<“,”>”等）がシートの名前に使用されている場合、そのシートは保存されません。

処理の詳細は特に気にならないという方は、zipファイルをダウンロードしてご利用ください。ダウンロードに抵抗がある場合は、ご自身でコードをローカルにコピペして、ご利用ください。

VBScript Script ファイル

ExcelSheetSplit ダウンロード

Sub Main ()
  On Error Resume Next

  ' --------
  ' 変数定義
  ' --------
  Dim objExcelApp, objWorkbookInFile, objSheet, objWorkbookAll, objName()

  ' ---------
  ' Excel起動
  ' ---------
  Set objExcelApp = CreateObject("Excel.Application")
  If objExcelApp Is Nothing Then
    MsgBox "Excelの起動に失敗しました。"
    exit sub
  End if

  ' ----------------
  ' 入力ファイル選択
  ' ----------------
  Set objWorkbookInFile = objExcelApp.Workbooks.Open(objExcelApp.GetOpenFilename("Microsoft Excelブック,*.xls?"),readonly) 
  ' 入力ファイルチェック
  If objWorkbookInFile Is Nothing Then
    MsgBox "入力ファイルを選択してください。"
    exit sub
  end if

  ' -------------------
  ' Excel画面の非表示化
  ' -------------------
  objExcelApp.Visible = false

  ' ----------------
  ' シート数カウント
  ' ----------------
  redim objName(cint(objWorkbookInFile.Sheets.Count))

  ' ----------------
  ' シート名一覧取得
  ' ----------------
  For i = 1 To objWorkbookInFile.Sheets.Count
    Set objSheet = objWorkbookInFile.Sheets(i)
    If objSheet.Visible Then
      objName(i)=objSheet.Name
      ' ---------------------------------------------
      ' シートコピー ※引数未指定で新しいbookにコピー
      ' ---------------------------------------------
      objSheet.Copy
    End If
  Next

  ' --------------------------
  ' 出力先フォルダ存在チェック
  ' --------------------------
  Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
  if false=objFSO.Folderexists(GetCurrentDir() & "\output") then
    ' ------------------
    ' 出力先フォルダ作成
    ' ------------------
    objFSO.CreateFolder(GetCurrentDir() & "\output")
  end if

  ' ------------
  ' ファイル保存
  ' ------------
  Set objWorkbookAll = objExcelApp.Workbooks
  i=0

  For Each objWorkbookAll in objExcelApp.Workbooks
    ' 入力ファイル以外の新規bookを対象
    if objWorkbookAll.name <> objWorkbookInFile.Name then
      ' ---------------------------------------
      ' シート名で保存 ※保存できない場合はSKIP
      ' ---------------------------------------
      objWorkbookAll.SaveAs GetCurrentDir() & "\output\" & objName(i) & ".xlsx"
      objWorkbookAll.close False
    end if
    i=i+1
  Next

  ' --------
  ' 終了処理
  ' --------
  objWorkbookInFile.Close false
  objExcelApp.Quit
  Set objWorkbookInFile = Nothing
  Set objWorkbookAll = Nothing
  Set objSheet = Nothing
  Set objExcelApp = Nothing

  MsgBox "処理を終了します。"
End Sub

' ------------------------
' カレントディレクトリ取得
' ------------------------
Function GetCurrentDir()
  On Error Resume Next
  Dim objShell : Set objShell = CreateObject("WScript.Shell")
  GetCurrentDir = objShell.CurrentDirectory
End Function

' ------------
' Main処理実行
' ------------
Main

先ずは上記コードを保存したExcelSheetSplit.vbsをダブルクリックします。