Excel VBA マクロを書き始めるためのメインプロシージャーテンプレート

何度も各部分を抜き出すとこういう感じでしょうか

使うときは

まずマクロを有効にしたうえで、さらにVBAのオブジェクトを信頼するにチェックを入れてください。

Accessがあることが前提です

Wordも使いますので、ないと動かない部分があります。

コードを書き込む場所

MainProsedureTemplateに書いていきます。
最初のところまでやたら長いのですが、正規表現、ADODB.Stream、FilesystemObject,連想配列、RGB分解、ADODB.Recordsetなど
また、これに加えて高速起動、Isformula2010、リターンキーを入れた時のカーソルの移動、テンキースィッチ起動、オプションの大体の標準化、A1表示設定などを行います。
また、ADODB.Streamなどはコメントを外すことによって起動できるようにしています。
また、Excelのマクロを数百以上、合計行数推定で延べ1万行以上の書いた結果、最も多い書き出しは最終行と右端の取得からであると決ドンづけました。ただし、そこに至るまではActivateを余計に重ねています。
またOption Compareなども既定の値のため省略可能ですが、あえて書いています。

参照設定の自動化

コード自体はLateBinding(CreatObject）ですが、参照設定を起動すれば参照設定が自動的に付加され、アーリーバインディングになります。
これだけの定数を書く一方で、この中にクリップボードを起動させるMicrosoft Forms2.0が、さらにCDを焼くというマイナーな作業のためのIMAPI、IMAPI2など、今まで使ったすべての参照設定を入れ込みました。もちろん、OUTLOOK、WORD、Accessも入っています。インターネット接続に必要な参照設定もバーコードも入っています。正規表現、FSO、WSH、Sheel.Applicationも入っています。さらに画像の日付を獲得する、ScannerとつなぐWIAもあります。

さらにクラスモジュールを追加してください

すでに作成しているDictinaryClass、classFSO,
SortedClass(System.Collection.Arraylist)を追加するとさらにいいです。これを入れることによりVBAでScriptControlなしでも配列にソートができるようになりました。
これに日付をコントロールするクラスを開発中です。

出来上がったらマクロ付きテンプレートにしてください。

そうするとOfficeのカスタムテンプレートというフォルダに保存されます。
これをダブルクリックすると、マクロが入って出来上がります。

Option Explicit
Option Compare Binary
Option Base 0
'Module Name = Main_Module
'Version 20200405
# If VBA7 Then
'Beep音を鳴らす
Declare PtrSafe Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' Unicode対応MegBox
Declare PtrSafe Function MessageBoxW Lib "user32" _
(ByVal hwnd As LongPtr, ByVal lpText As LongPtr, _
ByVal lpCaption As LongPtr, ByVal wType As Long) As Long
Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
# Else
Declare Function Beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function MessageBoxW Lib "user32" _
(ByVal hwnd As Long, ByVal lpText As Long, _
ByVal lpCaption As Long, ByVal wType As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
# End If
# If VBA7 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare PtrSafe Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
# Else
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
# End If
Public Type RGBClr
Rd As Long
Gr As Long
Bl As Long
End Type

' ----ADODOB.Steam 定数
' 参考サイト
' Reference '[ExcelWorkInof](https://excelwork.info/excel/adodbstream/)
' Global/Public 定数宣言部
' About ADODB.Steam Property ADODB.Stream.ConnectEnumMode
' ConnectModeEnum ' https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/connectmodeenum
' Stream.Mode Usable Enum is 3 [Mode Property] https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/mode-property-ado
Const adModeUnknown = 0, adModeRead = 1, adModeWrite = 2, adModeReadWrite = 3
Const adOpenStreamAsync = 1, adOpenStreamFromRecord = 4, _
adopenstreamunspecified = -1 'StreamOpenOptionsEnum Stream オブジェクトを開くときのオプションを表します OR 演算子　’https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/streamopenoptionsenum
Const adPosUnknown = -1, adPosBOF = -2, adPosEOF = -3 'PositionEnum https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/positionenum
Const adTypeText = 2, adTypeBinary = 1 'StreamTypeEnum 'https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/streamtypeenum
Const adReadAll = 1, adReadLine = -2 'StreamReadEnum 読み取りの時の定数。Stream オブジェクトから、ストリーム全体を読み取るか、または次の行を読み取るか。 'https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/streamreadenum
Const adWriteChar = 0, adWriteLine = -1 'StreamWriteEnum 'https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/streamwriteenum
Const adCRLF = -1, adCr = 13, adLF = 10 'LineSeparatorsEnum 'https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/lineseparatorsenum
Const adSaveCreateNotExist = 1, adSaveCreateOverWrite = 2 'SaveOptionsEnum SaveCreateNotExistファイルがないと作成　ファイルがあれば上書き AND結合可能 'https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/saveoptionsenum

Const adLockOptimistic = 3, adLockPessimistic = 2, adLockReadOnly = 1, adUseClient = 3, adLockBatchOptimistic = 4, adOpenStatic = 3, adOpenForwardOnly = 0, adOpenDynamic = 2 '  ADODB.LockTypeEnum のメンバー

' Scripting Filesystem Object Enum
Const ForReading = 1, ForWriting = 2, ForAppending = 8, TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Sub MainProsedureTemplate()
'オプション-全般-エラートラップは「発生時に中断」だと内容が0の配列でエラーを起こすため、[発生時に中断」以外を推奨
'常用
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim xWin As Excel.Window: Set xWin = Excel.ActiveWindow
Dim Rng As Excel.Range, iCol As Long, iRow As Long, LastRow As Long, LastCol As Long
Dim uRng As Range, DT As Date ' uRng はUsedRange用、DTは日付と時刻
Dim ClrCollection As Collection
Dim Cnt As Long, i As Long, Buf As String
Dim RGBCollection As Collection: Set RGBCollection = New Collection  'Collectionは色用 1 Red 2 Green 3 Blue
Dim vRGB As RGBClr
'FSO
Dim oFile, oFolder, TS, FSO: Set FSO = CreateObject("Scripting.Filesystemobject")
Dim oDic, kDic, Dicitem: Set oDic = CreateObject("Scripting.Dictionary")
Dim WSH: Set WSH = CreateObject("Wscript.Shell")
Dim SHL: Set SHL = CreateObject("Shell.Application")
Dim aRS As New ADODB.Recordset: Set aRS = CreateObject("ADODB.RecordSet")
Dim aCN As ADODB.Connection: Set aCN = CreateObject("ADODB.Connection")
Dim adCMD As ADODB.Command: Set adCMD = CreateObject("ADODB.Command")
' ADODOB.Streamを使う例
'Dim sr: Set sr = CreateObject("ADODB.Stream")
'With sr
'.Charset = "utf8"
'.Mode = adModeReadWrite
'.LineSeparator = adCRLF
'.Type = adTypeText
'.Open
'.WriteText
'.SaveToFile "Filename", adSaveCreateNotExist + adSaveCreateOverWrite
'.Close
'End With

' RGB に分解する例
'Set RGBCollection = ColorValueToRGB(6684927)
'With vRGB
'.Rd = RGBCollection(1)
'.Gr = RGBCollection(2)
'.Bl = RGBCollection(3)
'End With

' 正規表現 Regular Expression
Dim Reg, iMatch As Long, MC, SubMC, M: Set Reg = CreateObject("VBScript.RegExp")
'With Reg
'.Global = True
'.Pattern = "[0-9]{1}"
'.IgnoreCase = True
'.MultiLine = False
'Set MC = .Execute()
'If MC.Count > 0 Then
'For iMatch = 0 To MC.Count - 1
'Set M = MC.Item(iMatch)
'Next
'End With
'定石展開
wb.Activate
ws.Activate
Set uRng = ws.UsedRange
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
LastCol = uRng.Columns.Count
Set Rng = ws.Range(ws.Cells(1, 1).Address)
xlHiSpeed = True

'
' コードを記述
'

GoTo Err_Handle
Exit Sub
Err_Handle:
On Error Resume Next
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear
On Error GoTo 0
'Set sr = Nothing
Set aCN = Nothing
Set adCMD = Nothing
Set aRS = Nothing
Set FSO = Nothing
Set oDic = Nothing
Set WSH = Nothing
Set SHL = Nothing
Set Reg = Nothing
If Not RGBCollection Is Nothing Then
  Set RGBCollection = Nothing
End If
xlHiSpeed = False 'ハイスピード化終了をエラーが起きても実行させるためここに配置
NormalOptionMode = True 'NormalOptionModeを起動
'CellMoveDIrection = "R" ' Enterを押すと右に行くようになる。
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear 'なくてもいいが、何度も書くためコピペ用に記述
End Sub

Function isFormula2010(Rng As Range) As Boolean
'https://qiita.com/Q11Q/items/9399e5f9670232d1375c
'指定したRangeに関数が入っていればTrue Excel2013以降のRange.HasFormulaを使うと互換性がないため、これを使用する
If Rng.Count = 1 Then
If Rng.Value = CStr(Rng.Cells.Formula) Then isFormula2010 = False Else isFormula2010 = True
Else: isFormula2010 = False
End If
End Function

Function ColorValueToRGB(lgColorValue As Long)
Dim RgbArray As Collection
Set RgbArray = New Collection
RgbArray.Add lgColorValue Mod 256
RgbArray.Add lgColorValue / 256 Mod 256
RgbArray.Add lgColorValue / 65536 Mod 256
Set ColorValueToRGB = RgbArray
End Function
' Unicodeに対応したMsgBox
Sub MsgBoxEx(Texta As String, strCaption As String, wTypen As Long)
'StrPtr()関数で長整数型（Long）にキャスト
'VBA7ではキャプション、内容ともにLongPtr型にキャストする
' function fnMsgBoxExなどとして、通常のMegBoxと同様にvbYesNoができる。
' こちらは表示するのみ
MessageBoxW(GetFocus(), StrPtr(Texta), StrPtr(strCaption), wTypen)
End Sub
Function fnMsgBoxEx(Texta As String, strCaption As String, wTypen As Long) As Long
' 通常のMsgBoxのようにvbYesNoCancel、vbYesNo,vbOkCancelをwTypenに指定する。（vbYesNoCancel+vbInformationもできる）
' 返り値 Long
fnMsgBox = MessageBoxW(GetFocus(), StrPtr(Texta), StrPtr(strCaption), wTypen)
End Function
Sub AddReffernce()
'参照設定を開始する前にオブジェクトモデルへの信頼が必要です。
'これはOffice 2013以降で動作確認しています
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3 'VBIDE _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Microsoft Visual Basic for Applications Extensibility 5.3 _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB
Call AddReference2
End Sub
Private Sub AddReference2()
Dim vRef, vRefs
Dim i As Long
' Office 2013以降が前提。フルパス
If Application.Version < 15 Then Exit Sub

On Error Resume Next
Set vRefs = Application.VBE.ActiveVBProject.References
With Application.VBE.ActiveVBProject.References
'.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 4, 2 'VBA Visual Basic For Applications   C:\Program Files\Common Files\Microsoft Shared\VBA\VBA7.1\VBE7.DLL
'.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 1, 9 'Excel   Microsoft Excel 16.0 Object Library C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE
'.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 2, 0 'stdole  OLE Automation  C:\Windows\System32\stdole2.tlb
.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 2, 8 'Office  Microsoft Office 16.0 Object Library    C:\Program Files\Common Files\Microsoft Shared\OFFICE16\MSO.DLL
.AddFromGuid "{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5 'VBScript_RegExp_55  Microsoft VBScript Regular Expressions 5.5  C:\Windows\System32\vbscript.dll\3
.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 2, 8 'Office  Microsoft Office 16.0 Object Library    C:\Program Files\Common Files\Microsoft Shared\OFFICE16\MSO.DLL
.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 2, 0 'MSForms Microsoft Forms 2.0 Object Library  C:\WINDOWS\system32\FM20.DLL
.AddFromGuid "{F935DC20-1CF0-11D0-ADB9-00C04FD58A0B}", 1, 0 'IWshRuntimeLibrary  Windows Script Host Object Model    C:\Windows\System32\wshom.ocx
.AddFromGuid "{563DC060-B09A-11D2-A24D-00104BD35090}", 1, 0 'WSHControllerLibrary        C:\Windows\System32\wshcon.dll
.AddFromGuid "{94A0E92D-43C0-494E-AC29-FD45948A5221}", 1, 0 'WIA Microsoft Windows Image Acquisition Library v2.0    C:\WINDOWS\System32\wiaaut.dll
.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0 'Scripting   Microsoft Scripting Runtime C:\Windows\System32\scrrun.dll
.AddFromGuid "{50A7E9B0-70EF-11D1-B75A-00A0C90564FE}", 1, 0 'Shell32 Microsoft Shell Controls And Automation C:\Windows\SysWOW64\shell32.dll
' OutLook 電子メールを作成する
.AddFromGuid "{00062FFF-0000-0000-C000-000000000046}", 9, 6 'Outlook Microsoft Outlook 16.0 Object Library   C:\Program Files\Microsoft Office\root\Office16\MSOUTL.OLB
.AddFromGuid "{0006F062-0000-0000-C000-000000000046}", 1, 2 'OLXLib  Microsoft Outlook View Control  C:\Program Files\Microsoft Office\root\Office16\OUTLCTL.DLL
' Microsoft Word TaskObjectなどとマイナーな使い方がある
.AddFromGuid "{00020905-0000-0000-C000-000000000046}", 8, 7 'Word    Microsoft Word 16.0 Object Library  C:\Program Files\Microsoft Office\root\Office16\MSWORD.OLB

' MSAccess.Exeがないと多分エラー
.AddFromGuid "{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}", 9, 0 'Access  Microsoft Access 16.0 Object Library    C:\Program Files\Microsoft Office\root\Office16\MSACC.OLB
.AddFromGuid "{4AC9E1DA-5BAD-4AC7-86E3-24F4CDCECA28}", 12, 0 'DAO(Not 3.6)  Microsoft Office 16.0 Access database engine Object Library C:\Program Files\Common Files\Microsoft Shared\OFFICE16\ACEDAO.DLL

' データベース関連
.AddFromGuid "{B691E011-1797-432E-907A-4D8C69339129}", 6, 1 'ADODB   Microsoft ActiveX Data Objects 6.1 Library  C:\Program Files\Common Files\System\ado\msado15.dll
.AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 6, 0 'ADOX    Microsoft ADO Ext. 6.0 for DDL and Security C:\Program Files\Common Files\System\ado\msadox.dll
.AddFromGuid "{2358C810-62BA-11D1-B3DB-00600832C573}", 4, 0 'JetES   JET Expression Service Type Library C:\Windows\SysWOW64\msjtes40.dll
.AddFromGuid "{AC3B8B4C-B6CA-11D1-9F31-00C04FC29D52}", 2, 6 'JRO Microsoft Jet and Replication Objects 2.6 Library   C:\Program Files (x86)\Common Files\System\ado\msjro.dll
.AddFromGuid "{E0E270C2-C0BE-11D0-8FE4-00A0C90A6341}", 1, 5 'MSDAOSP Microsoft OLE DB Simple Provider 1.5 Library    C:\Windows\System32\simpdata.tlb
' 読み上げ関係
.AddFromGuid "{C866CA3A-32F7-11D2-9602-00C04F8EE628}", 5, 4 'SpeechLib   Microsoft Speech Object Library C:\WINDOWS\System32\Speech\Common\sapi.dll
.AddFromGuid "{EB2114C0-CB02-467A-AE4D-2ED171F05E6A}", 10, 0 'TTSEngineLib   Microsoft TTS Engine 10.0 Type Library  C:\Windows\System32\speech\engines\tts\MSTTSEngine.dll

With CreateObject("WScript.shell")
If CreateObject("Scripting.FilesystemObject").FileExists(.ExpandEnvironmentString("%ProgramW6432%") & "\Microsoft Office\root\Office16\Library\EUROTOOL.XLAM") Then
Application.AddFromFile _
Application.LibraryPath & "\EUROTOOL.XLAM"  'EuroTool  Euro Transition Tools (B)   C:\Program Files\Microsoft Office\root\Office16\Library\EUROTOOL.XLAM
'Application.LibraryPath を使うと64/32、Versionの違いを乗り越えられる
'https://answers.microsoft.com/ja-jp/msoffice/forum/all/library%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80/9f5d4d0e-2e51-485f-90b6-277218c4b43c
End If
End With
' インターネット関係
.AddFromGuid "{662901FC-6951-4854-9EB2-D9A2570F2B2E}", 5, 1 'WinHttp Microsoft WinHTTP Services, version 5.1 C:\WINDOWS\system32\winhttpcom.dll
.AddFromGuid "{F5078F18-C551-11D3-89B9-0000F81FE221}", 6, 0 'MSXML2  Microsoft XML, v6.0 C:\Windows\System32\msxml6.dll
.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 4, 0 'MSHTML  Microsoft HTML Object Library   C:\Windows\System32\mshtml.tlb
.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 1, 1 'SHDocVw Microsoft Internet Controls C:\Windows\System32\ieframe.dll
' いろいろな機能がある
.AddFromGuid "{D37E2A3E-8545-3A39-9F4F-31827C9124AB}", 2, 4 'System_Drawing  System.Drawing.dll  C:\Windows\Microsoft.NET\Framework64\v4.0.30319\System.Drawing.tlb
.AddFromGuid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4 'mscorlib    mscorlib.dll    C:\Windows\Microsoft.NET\Framework64\v4.0.30319\mscorlib.tlb
' システムの設定などを呼び出す
.AddFromGuid "{565783C6-CB41-11D1-8B02-00600806D9B6}", 1, 2 'WbemScripting   Microsoft WMI Scripting V1.2 Library    C:\Windows\System32\wbem\wbemdisp.TLB
' バーコード
.AddFromGuid "{D9347025-9612-11D1-9D75-00C04FCC8CDC}", 1, 0 'BARCODELib  Microsoft Access BarCode Control 14.0   C:\Program Files\Microsoft Office\root\Office16\MSBCODE9.OCX
' CD/DVDを焼くツール
.AddFromGuid "{2735412F-7F64-5B0F-8F00-5D77AFBE261E}", 1, 0 'IMAPI2  Microsoft IMAPI2 Base Functionality C:\Windows\System32\imapi2.dll
.AddFromGuid "{2C941FD0-975B-59BE-A960-9A2A262853A5}", 1, 0 'IMAPI2FS    Microsoft IMAPI2 File System Image Creator  C:\Windows\System32\imapi2fs.dll
' CDトレイを開く
.AddFromGuid "{6BF52A50-394A-11D3-B153-00C04F79FAA6}", 1, 0 'WMPLib  Windows Media Player    C:\WINDOWS\system32\wmp.dll

End With
For i = 1 To vRefs.Count
Set vRef = vRefs.Item(i)
With vRef
Debug.Print ".AddFromGUID """ & vRef.GUID & """, " & vRef.Major & ", " & vRef.Minor & "'" & .Name & vbTab & .Description _
& vbTab & .FullPath
End With
Next
End Sub

Private Sub RunOnScreenKeyBord6432()
Const SW_SHOWNORMAL = 1
On Error Resume Next
With CreateObject("WScript.Shell")
Debug.Print .ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%")
If .ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%") <> "AMD64" And _
 .ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%") <> "IA64" And _
  .ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%") <> "ARM64" Then
    Wow64EnableWow64FsRedirection False
    ShellExecute 0, "open", "osk.exe", "", "C:\windows\system32\osk.exe", SW_SHOWNORMAL
    Wow64EnableWow64FsRedirection True
Else
    ShellExecute 0, "open", "osk.exe", "", "C:\windows\system32\osk.exe", SW_SHOWNORMAL
End If
End With
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear
End Sub

Property Let CellMoveDIrection(Buf As String)
'Enterを押したときの移動方向を変える。動かないときは動くオプションにまず変更する
With Application
If .MoveAfterReturn = Not True Then
  Debug.Print ".MoveAfterReturn From False to True"
  .MoveAfterReturn = Not .MoveAfterReturn
End If
Select Case .MoveAfterReturnDirection
Case Is = -4121
 Debug.Print "xlDown"
Case Is = -4161
 Debug.Print "xltoRight"
Case Is = -4159
 Debug.Print "xltoLeft"
Case Is = -4162
 Debug.Print "xlUp"
End Select

Select Case Buf
Case Is = "xlDown", "Down", "d", "D", "-4121", "4121"
If .MoveAfterReturnDirection <> xlDown Then
.MoveAfterReturnDirection = xlDown
Else
Debug.Print "No Change"
Exit Property
End If

Case Is = "xltoRight", "Right", "R", "r", "-4161", "4161"
If .MoveAfterReturnDirection <> xlToRight Then
.MoveAfterReturnDirection = xlToRight
Else
Debug.Print "No Change"
Exit Property
End If

Case Is = "xltoLeft", "Left", "l", "L"
If .MoveAfterReturnDirection <> xlToLeft Then
.MoveAfterReturnDirection = xlToLeft
Else
Debug.Print "No Change"
Exit Property
End If

Case Is = "xlUP", "Up", "u", "U"
If .MoveAfterReturnDirection <> xlDown Then
.MoveAfterReturnDirection = xlDown
Else
Debug.Print "No Change"
Exit Property
End If

Case Else
.MoveAfterReturnDirection = xlDown
Debug.Print "Direction is xlDown. Unknown value buf = " & Buf
Exit Property
End Select
Debug.Print "Cell move after return key dIrection change to "
Select Case .MoveAfterReturnDirection
Case Is = -4121
Debug.Print "xlDown"
Case Is = -4161
Debug.Print "xltoRight"
Case Is = -4159
Debug.Print "xltoLeft"
Case Is = -4162
Debug.Print "xlUp"
End Select
End With
End Property

Property Let NormalOptionMode(blSwitch As Boolean)
'標準的と思われるプロパティに調整する
'調整したときはイミディエイトに表示する

'Wordがないと動かない
Dim wApp: Set wApp = CreateObject("Word.Application")
Dim WSH: Set WSH = CreateObject("Wscript.Shell")
With Application
wApp.Options.INSKeyForOvertype = False
If wApp.NumLock = Not blSwitch Then
WSH.SendKeys "{NUMLOCK}"
End If
If wApp.CapsLock = blSwitch Then
WSH.SendKeys "{CapsLock}"
End If
End With
wApp.Quit
Set wApp = Nothing
Set WSH = Nothing
' 以上、ここまでがWordを使ってキーアサインを判定して調整する。これがあるので多少重い。
With Application
If .CellDragAndDrop <> blSwitch Then
   Debug.Print "CellDragAndDrop Change From " & CBool(.CellDragAndDrop) & "To " & Not blSwitch
   .CellDragAndDrop = blSwitch
End If
If .EnableAnimations <> Not blSwitch Then
   Debug.Print "EnableAnimations  Change From " & CBool(.EnableAnimations) & "To " & Not blSwitch
   .EnableAnimations = Not blSwitch
End If
If .EnableSound <> Not blSwitch Then
   Debug.Print "EnableSound Change From " & CBool(.EnableSound) & "To " & Not blSwitch
   .EnableSound = Not blSwitch
End If

If .EnableLargeOperationAlert <> blSwitch Then
   Debug.Print "EnableLargeOperationAlert  Change From " & CBool(.EnableLargeOperationAlert) & "To " & blSwitch
   .EnableLargeOperationAlert = blSwitch
End If
.ActiveWindow.View = xlNormalView
If .ShowDevTools <> blSwitch Then
   Debug.Print "ShowDevTools  Change From " & CBool(.ShowDevTools) & "To " & blSwitch
   .ShowDevTools = blSwitch
End If
If .ReferenceStyle <> xlA1 Then
   Debug.Print "ReferenceStyle Change From xlR1C1 to lA1"
   .ReferenceStyle = IIf(blSwitch, xlA1, xlR1C1)
End If

If .ShowMenuFloaties <> blSwitch Then
   Debug.Print "ShowMenuFloaties Change From " & CBool(.ShowMenuFloaties) & "To " & blSwitch
   .ShowMenuFloaties = blSwitch
End If
End With
End Property

Property Let xlHiSpeed(blSwitch As Boolean)
' [VBA マクロ高速化のために停止すべき3項目](https://thom.hateblo.jp/entry/2015/08/31/063500)
'これにステータスバーとWindowの最小化を加える
With Application
.WindowState = IIf(blSwitch, xlMaximized, xlMaximized)
.StatusBar = ""
.DisplayAlerts = Not blSwitch
.ScreenUpdating = Not blSwitch
.EnableEvents = Not blSwitch
.Calculation = IIf(blSwitch, xlCalculationManual, xlCalculationAutomatic)
End With
End Property