【VBS】Excelファイル(複数も可能)をドラッグ＆ドロップで全シートA1セル移動ツール

はじめに

これは、Visual Basic Advent Calendar 2021の11日目の記事となります。

ネタ探しに、Yahooリアルタイム検索でVisual Basic関連で検索していた時に、下記のツイートを見つけました。

懺悔します。Excel資料はA1にカーソル合わせて保存してから、顧客に提出するようにという文化を真面目にこなしていた時期がありました。後輩に指導したこともありました。誠に申し訳ございませんでした。

— むぎSE (@MUGI1208) December 9, 2021

返信コメントを読んだり、Yahooリアルタイム検索で「Excel A1」で検索すると、ExcelのセルA1に合わせるという文化(マナー)、Excel資料をA1にカーソル合わせて保存しなくて先輩に説教されたりとかありますね。

A1に合わせる理由・根拠

ファイルを開いた位置が最初（端）であると勘違いして、それより上や左のセルが存在することに気づかず事故った例も見受けられるのと、見る側としては途中から始まると気持ち悪い（マナー的なもの）。

対応方法

PDFにして出力

ExcelではなくPDFにして顧客に提出する。
最終結果を確認しないと改ページ不備で出力されていなかったり、表示幅がズレておかしくなっていたりで修正に時間がかかったりする。

Ctrl＋HomeでA1セルにする癖を付ける

シートを保存する際にショートカットキー「Ctrl ＋ Home」でA1セルにして保存する癖をつける。
癖なので。忘れてしまうデメリットがある。

Excelマクロを導入

「excel マクロ a1 移動」で検索した中で、下記の2つを紹介します。
2つ目はシート非表示やウインドウ枠固定やフィルター設定などまで考慮されています。

ExcelアドインのRelaxTools Addinを導入

ExcelアドインのRelaxTools Addinには多くの機能があり、その中に「全シートＡ１にして上書き保存」や「全シートのカーソルをＡ１セット」する機能が備わっています。
https://software.opensquare.net/relaxtools/about/

Excel全シート表示位置指定ツールの紹介

今回のメイン記事となります。

2014年5月18日に別ブログで、VBScriptで組んだ「Excel全シート表示位置指定ツール」を公開していたのですが、このブログは壊れていてダウンロードが出来なくなっています。

今回、Qiitaにて復活させることにしました。

作成のきっかけ

Excel全シート表示位置指定ツールを作成したきっかけは、同僚が上長からExcelの資料の全シートの表示位置を左上にしておいてという指示を聞いたからです。
その同僚はExcelで全シートを選択して左上に表示位置をセットしましたが、全シートの表示位置は変わりませんでした。
ネットで調べてみるとマクロ組むしかないようだったので、これはいいネタが見つかったと思って今回作ってみました。

使い方

Excel全シート表示位置指定.vbs　をデスクトップまたはローカルフォルダに置きます。
全シート表示位置指定したいExcelファイル(複数も可能)をドラッグ＆ドロップします。
(Excelファイルが入っているフォルダをドラッグ＆ドロップした場合、その中のExcelファイルが全て対象となります)

表示位置を指定する入力ダイアログが表示されます。表示位置を指定して「OK」ボタンを押してください。
なお、既定では左上の「A1」がセットされています。
Excelの全シートを指定の表示位置にした上で、アクティブシートを先頭シートにして保存します。
一応、保存するのでバックアップは念のためにしておいてください。

※なお、シート非表示やウインドウ枠固定やフィルター設定時の考慮まではしていません。必要ならソースコードを改変してください。

ソースコード

Excel全シート表示位置指定ツール.vbs

Option Explicit
'On Error Resume Next

Dim WshShell, fso, excel, objArgs, dic, MyFile, xlsNm, xlsBook
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set dic = CreateObject("Scripting.Dictionary")
Set excel = WScript.CreateObject("Excel.Application")

Const xlSheetVisible = -1

'引数取得
Set objArgs = WScript.Arguments

Dim res, f, sheet, actCell, vState

If StrComp(fso.GetExtensionName(objArgs(0)),"xls",vbTextCompare)=0  Or _
   StrComp(fso.GetExtensionName(objArgs(0)),"xlsx",vbTextCompare) = 0 Then
    For Each f In objArgs
        dic.Add f,f
    Next
    res = MsgBox(objArgs(0) + "の全シートを表示位置にしますか？", vbYesNo, "全シートの表示位置")
Else
    GetAllSolutionFiles objArgs(0)
    res = MsgBox(objArgs(0) + "内の" + CStr(dic.Count) + "個、全シートを表示位置にしますか？", vbYesNoCancel, "全シートの表示位置")
End If

If dic.Count = 0 Then
    MsgBox "Excelファイルがありません"
Else
    If res = vbYes Then
        actCell = InputBox("全シートの表示位置セルを指定してください。","表示位置セル入力", "A1")
        If IsEmpty(actCell) = true Then
            MsgBox "キャンセルしました。"
        Else
            excel.Visible = false
            For Each f in dic.Items
                Set xlsBook = excel.Workbooks.Open (f)
                xlsBook.CheckCompatibility = False
                For Each sheet In xlsBook.Sheets
                    vState = sheet.Visible
                    If sheet.Visible <> xlSheetVisible Then sheet.Visible = xlSheetVisible
                    sheet.Select
                    sheet.Range(actCell).Select
                    If vState <> xlSheetVisible Then sheet.Visible = vState
                Next
                xlsBook.Sheets(1).Activate

                xlsBook.Save   '保存の確認をしたい場合は、この行をコメントアウトして下さい。 'xlsBook.Save  
                xlsBook.CheckCompatibility = True

                excel.quit
            Next

            MsgBox CStr(dic.Count) + "個の全シートを" + actCell + "にしました。"
        End If
    End If
End If


Sub GetAllSolutionFiles(strFolder)
    Dim str, s

    If fso.FolderExists(strFolder) = False Then Exit Sub

    GetSolutionFiles strFolder

    'サブフォルダで実行
    Dim folder, subfolders
    Set folder = fso.GetFolder(strFolder)
    Set subfolders = folder.SubFolders
    For Each s in subfolders
        GetAllSolutionFiles s
    Next
End Sub

Sub GetSolutionFiles(strFolder)
    Dim folder, files, f

    If fso.FolderExists(strFolder) = False Then Exit Sub

    'フォルダ内のすべてのファイル
    Set folder = fso.GetFolder(strFolder)
    Set files = folder.Files

    For Each f In files
        If StrComp(fso.GetExtensionName(f),"xls",vbTextCompare) = 0 Or _
           StrComp(fso.GetExtensionName(f),"xlsx",vbTextCompare) = 0 Then
            dic.Add f, f
        End If
    Next
End Sub

ライセンスっぽいこと

コード改変や配布は自由です。
このツールによる義務／責任を何ら負いません。

最後に

2014年5月に作成したもので当時はExcel2010でした。今回、Excel for Microsoft 365でも問題ないか確認してみました。
ちゃんとA1セルに移動されていました。

Excelファイルが複数あった場合、ExcelアドインのRelaxTools AddinやExcelマクロだと、Excelファイルを1つ1つ開いて保存しないといけませんが、VBScriptで作成した今回のツールならExcelファイル(複数も可能)をドラッグ＆ドロップすれば、一括して全シートをA1セルに移動してくれるので、これはこれで便利だと思います。