vbscript 指定したファイルの全てのシートについてA1セルを有效にするスクリプト

Posted 2021-05-22

Option Explicit

'/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'指定したエクセルファイルの全てのシートのセルをA1セルへ移動するスクリプト
'エクセルの指定はダイアログ、D&Dをサポート
'/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

Call ActivateA1

Private Sub ActivateA1()
	Dim objExcel

	'起動中のExcelの流用を優先します。	
	On Error Resume Next
	Set objExcel = WScript.GetObject(, "Excel.Application")
	If Err.Number <> 0 Then
		Err.Clear
		On Error GoTo 0
		Set objExcel = WScript.CreateObject("Excel.Application")
	End If	
	objExcel.Visible = True

	Dim args
	Set args = WScript.Arguments
	Dim filePath
	If args.length > 0 Then
		filePath = args(0)
	End If

	If filePath = "" Then
		filePath = objExcel.GetOpenFilename("Excelファイル,*.xls;*.xlsx")
		
		If filePath = "False" Then
			Exit Sub
		End If
	End If
	
	Dim xWB, xBook
	Set xWB = Nothing
	
	For Each xBook In objExcel.Workbooks
		If xBook.Path & "\" & xBook.Name = filePath Then
			Set xWB = xBook
			Exit For
		End If
	Next
	
	If xWB Is Nothing Then
		Set xWB = objExcel.Workbooks.Open(filePath)
	End If
	objExcel.ScreenUpdating = False
	
	Dim xSheet
	For Each xSheet In xWB.Worksheets
		If xSheet.Visible then
			xSheet.Activate
			Call objExcel.Goto(xSheet.Range("A1"), True)
		End If
	Next
	xWB.Worksheets(1).Activate
	objExcel.ScreenUpdating = True
	MsgBox "問題がなければ保存してください。"
'	objExcel.WindowState = -4137 'max
	objExcel.WindowState = -4143 'min
	
End Sub