LoginSignup
1
3

More than 5 years have passed since last update.

Excelファイルのカーソルをホームポジションに設定するスクリプト

Last updated at Posted at 2015-07-08

Excelファイルのカーソルをホームポジションに設定するスクリプト

Excelファイルのカーソルをホームポジションに設定するスクリプトです。

  • 全てのシートのカーソルをホームポジションにします。(非表示シートは除外)
  • シートの一番最初を選択します。
  • ズームを100%に変更します。

複数ファイル、サブディレクトリ対応です。
読み取りパスワードが指定されているものにも対応します。

使い方

  1. ホームポジション設定するExcelファイルのフォルダにこのスクリプトを配置する。
  2. スクリプトの「拡張子」「読み取りパスワード」を必要に応じて書き換える。
  3. スクリプトを実行する。
  4. 結果をテキストファイルで表示する。
Excelファイルのカーソルをホームポジションに設定
'-------------------------------------------------------------------------------
' Excelファイルのカーソルをホームポジションに設定
' 
' ExcelSetHomePosition.vbs
' Version 1.0.0
' 
' Copyright (c) 2015 Y.Watanabe
' 
' This software is released under the MIT License.
' http://opensource.org/licenses/mit-license.php
'-------------------------------------------------------------------------------
' 動作確認 : Windows 7 + Excel 2010 / Windows 8 + Excel 2013
'-------------------------------------------------------------------------------
' for Used
' (1) ホームポジション設定するExcelファイルのフォルダにこのスクリプトを配置する。
' (2) スクリプトの「拡張子」「読み取りパスワード」を必要に応じて書き換える。
' (3) スクリプトを実行する。
' (4) 結果をテキストファイルで表示する。
' 
'-------------------------------------------------------------------------------
    Option Explicit

    Dim objFs, strMsg, SH
    Dim objDic, XL, WB, FL, LogName
    dim varPatterns, strKey, varPass, p
    Dim IE
    Dim strTitle

    strTitle = "ホームポジション設定"

    If MsgBox("同フォルダ以下のExcelファイルをホームポジション設定します。" & vbCrLf & "よろしいですか?" & VbCrLf & VbCrLf & "☆お約束☆" & vbCrLf & "Excelファイルは事前にバックアップしてください。", vbYesNo + vbQuestion, strTitle) = vbNo Then 
        WScript.Quit 
    End IF

    Set IE = WScript.CreateObject("InternetExplorer.Application")

    IE.Navigate "about:blank"
    Do While IE.busy
        WScript.Sleep(100)
    Loop
    Do While IE.Document.readyState <> "complete"
        WScript.Sleep(100)
    Loop
    IE.Document.body.innerHTML = "<b id=""msg"">ホームポジション設定中です<br>しばらくお待ち下さい...</b>"
    IE.AddressBar = False
    IE.ToolBar = False
    IE.StatusBar = False
    IE.Height = 120
    IE.Width = 300
    IE.Left = 0
    IE.Top = 0
    IE.Document.Title = strTitle
    IE.Visible = True

    On Error Resume Next

    Set objFs =  WScript.CreateObject("Scripting.FileSystemObject")
    Set objDic = WScript.CreateObject("Scripting.Dictionary")

    '--------------------------------------------------------------
    ' 処理を行う拡張子を正規表現で記述
    '--------------------------------------------------------------
    varPatterns = Array("\.xls$", "\.xlsx$", "\.xlsm$")

    '--------------------------------------------------------------
    ' 読み取りパスワードがある場合はここに記述(複数指定可)
    '--------------------------------------------------------------
    varPass = Array("", "", "")

    FileSearch objFs, objFs.GetParentFolderName(WScript.ScriptFullName), varPatterns, objDic

    LogName = objFs.GetBaseName(WScript.ScriptFullName) & ".txt"
    Set FL = objFs.CreateTextFile(LogName)

    FL.WriteLine "☆=ホームポジション設定 開始(" & Now() & ")☆="
    FL.WriteLine "処理ファイル数:" & objDic.Count

    If objDic.Count > 0 Then

        Set XL = WScript.CreateObject("Excel.Application")

        For Each strKey In objDic.Keys

            'パスワード指定の場合
            For Each p In varPass
                Err.Clear
                Set WB = XL.WorkBooks.Open(objDic(strKey),,False,,p,"",True,,,False)
                If Err.Number = 0 Then
                    Exit For
                End If
            Next

            Select Case True
                Case Err.Number <> 0
                    FL.WriteLine "エラー => " & objDic(strKey)
                    FL.WriteLine "          " & Err.Description

                Case WB.ReadOnly 
                    FL.WriteLine "エラー => " & objDic(strKey)
                    FL.WriteLine "          ブックが読み取り専用です"

                Case Else
                    setAllA1 WB

                    XL.DisplayAlerts = False
                    WB.Save

                    If Err.Number <> 0 Or WB.Saved = False Then
                        FL.WriteLine "エラー => " & objDic(strKey)
                        FL.WriteLine "          " & Err.Description
                    Else
                        FL.WriteLine "処理済 => " & objDic(strKey)
                    End If

                    XL.DisplayAlerts = True
            End Select

            'インスタンスがあれば Close
            If Not IsNothing(WB) Then
                WB.Close
                Set WB = Nothing
            End If
        Next

        XL.Quit

        Set XL = Nothing

    End If

    FL.WriteLine "☆=ホームポジション設定 終了(" & Now() & ")☆="
    FL.Close
    Set FL = Nothing

    Set objDic = Nothing
    Set objFs =  Nothing

    With CreateObject("Shell.Application")
        .ShellExecute(LogName)
    End With

    IE.Quit
    'MsgBox "処理が完了しました。", vbInformation + VbOkOnly, strTitle

'--------------------------------------------------------------
' すべてのシートの選択位置をA1にセット
'--------------------------------------------------------------
Sub setAllA1(WB)

    Dim WS
    Dim WD

    For Each WS In WB.Worksheets
        If WS.visible Then
            WS.Activate
            WS.Range("A1").Activate
            WB.Windows(1).ScrollRow = 1
            WB.Windows(1).ScrollColumn = 1
            WB.Windows(1).Zoom = 100
        End If
    Next

    '表示中の1枚目にする。
    For Each WS In WB.Worksheets
        If WS.visible  Then
            WS.Select
            Exit For
        End If
    Next

End Sub

'--------------------------------------------------------------
' サブフォルダ検索
'--------------------------------------------------------------
Private Sub FileSearch(objFs, strPath, varPatterns, objDic)

    Dim objfld
    Dim objfl
    Dim objSub
    Dim f, objRegx

    Set objfld = objFs.GetFolder(strPath)

    'ファイル名取得
    For Each objfl In objfld.files

        Dim blnFind
        blnFind = False

        Set objRegx = CreateObject("VBScript.RegExp")
        For Each f In varPatterns
            objRegx.Pattern = f
            If objRegx.Test(objfl.name) Then
                blnFind = True
                Exit For
            End If
        Next
        Set objRegx = Nothing

        If blnFind Then
            objDic.Add objFs.BuildPath(objfl.ParentFolder.Path, objfl.name), objFs.BuildPath(objfl.ParentFolder.Path, objfl.name)
        End If
    Next

    'サブフォルダ検索あり
    For Each objSub In objfld.SubFolders
        FileSearch objFs, objSub.Path, varPatterns, objDic
    Next

End Sub
1
3
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
1
3