Option Explicit

Sub リンク作成()
    
    Dim i As Long
    For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row
        Hyperlinks.Add anchor:=Cells(i, 3), Address:="", SubAddress:="", TextToDisplay:="実行"
    Next
    
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    
    Dim ジャンル As String
    ジャンル = Target.Range.Offset(0, 1).Value
    
    Dim 最初のセル As Range
    Set 最初のセル = Target.Range.Offset(0, 2)
    
    Select Case ジャンル
        Case "フォルダ"
            Call フォルダ(最初のセル)
        Case "Zoom"
            Call Zoom(最初のセル)
    End Select
    
End Sub

Sub フォルダ(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "*無題 - メモ帳"
    Call ySendKeys("^V")
    Call ySendKeys("{TAB}")
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    Call ySendKeys("^V")
    Call ySendKeys(" ")
    Call ySendKeys("{TAB}")
    
    Application.CutCopyMode = False
    
End Sub

Sub Zoom(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "Zoom"
    Call ySendKeys("^V")
    Call ySendKeys("{TAB}{TAB}{TAB}{TAB}")
    Call ySendKeys(" ")
    Call ySendKeys("{TAB}")
    Call ySendKeys(" ", 2)                          '2秒とめる
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    AppActivate "ミーティングパスコードを入力"
    Call ySendKeys("^V")
    Call ySendKeys("{TAB}")
    Call ySendKeys(" ", 5)                          '5秒とめる
    
    Call ySendKeys(" ")
    
    Application.CutCopyMode = False
    
End Sub

Private Function ySendKeys(Keys As String, Optional Time As Double = 0.5, Optional Wait As Boolean = True)
    
    Call Application.SendKeys(Keys, Wait)
    Call Application.Wait([Now()] + Time / 86400)
    
End Function

Option Explicit

Sub リンク作成()
    
    Dim i As Long
    
    For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row
        Hyperlinks.Add anchor:=Cells(i, 3), Address:="", SubAddress:="", TextToDisplay:="実行"
    Next
    
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    
    Dim ジャンル As String
    ジャンル = Target.Range.Offset(0, 1).Value
    
    Dim 最初のセル As Range
    Set 最初のセル = Target.Range.Offset(0, 2)
    
    Select Case ジャンル
        Case "フォルダ"
            Call フォルダ(最初のセル)
        Case "Zoom"
            Call Zoom(最初のセル)
    End Select
    
End Sub

Sub フォルダ(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "エクスプローラ":                   Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{ENTER}", True
    
    Application.CutCopyMode = False
    
End Sub

Sub Zoom(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "Zoom":                             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    
    Application.Wait [Now() + "00:00:02"]           '2秒とめる(PW画面に移るまで時間かかるため)
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    AppActivate "ミーティングパスコードを入力":     Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    
    Application.Wait [Now() + "00:00:05"]           '5秒とめる(接続に時間がかかるため)
    
    Application.SendKeys " ", True
    
    Application.CutCopyMode = False
    
End Sub

Option Explicit
Const フォルダパスの行数 = 3
Const 元の列数 = 2
Const コピー先の列数 = 3
Const 最初の行 = 6

Sub リネーム()
    
    Dim ws作業シート As Worksheet
    Set ws作業シート = ThisWorkbook.ActiveSheet
    
    Rem コピー先の指定がなければフォルダを作成
    If ws作業シート.Cells(フォルダパスの行数, コピー先の列数) = "" Then
        MkDir ws作業シート.Cells(フォルダパスの行数, 元の列数) & "\リネーム後"
        ws作業シート.Cells(フォルダパスの行数, コピー先の列数) = ws作業シート.Cells(フォルダパスの行数, 元の列数) & "\リネーム後"
    End If
    
    Dim 最後の行 As Long
    最後の行 = ws作業シート.Cells(Rows.Count, 元の列数).End(xlUp).Row
    
    Rem コピー＆リネーム
    Dim f As Long
    For f = 最初の行 To 最後の行
        FileCopy ws作業シート.Cells(フォルダパスの行数, 元の列数).Value & "\" & ws作業シート.Cells(f, 元の列数).Value, _
                 ws作業シート.Cells(フォルダパスの行数, コピー先の列数).Value & "\" & ws作業シート.Cells(f, コピー先の列数).Value
    Next
    
    MsgBox "コピー＆リネーム完了！"
    
End Sub

Sub 全シートの保護と解除()
    
選択:
    
    Rem 保護の設定・解除の選択
    Dim 選択 As Long
    選択 = Application.InputBox(Prompt:="処理を選択してください" & vbCrLf & vbCrLf & "　1 = 保護   2 = 解除   0 = キャンセル", Type:=1)
    
    Rem キャンセルと再選択
    If 選択 = False Then GoTo キャンセル処理
    If Not (選択 = 1 Or 選択 = 2) Then
        MsgBox "1 か 2 を入力してください"
        GoTo 選択
    End If
    
    Rem パスワードの入力
    Dim GetPW As String
    Select Case 選択
        Case 1
            GetPW = Application.InputBox(Prompt:="保護パスワードを入力してください", Type:=2)
            If GetPW = False Then GoTo キャンセル処理
            Call 保護(GetPW)
        Case 2
            GetPW = Application.InputBox(Prompt:="解除パスワードを入力してください", Type:=2)
            If GetPW = False Then GoTo キャンセル処理
            Call 保護解除(GetPW)
    End Select
    
    Exit Sub
    
キャンセル処理:
    MsgBox "キャンセルしました"
    
End Sub

Sub 保護(ByVal PW As String)
    
    Rem シートの保護
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Protect Password:=PW, UserInterfaceOnly:=True     'マクロでの操作は許可
    Next
    
    Rem ブックの保護
    ActiveWorkbook.Protect Password:=PW, Structure:=True, Windows:=False
    
End Sub

Sub 保護解除(ByVal PW As String)
    
    Rem シートの保護解除
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Unprotect Password:=PW
    Next
    
    Rem ブックの保護解除
    ActiveWorkbook.Unprotect Password:=PW
    
End Sub

Sub 全シートの保護と解除()
    
    On Error GoTo キャンセル処理
    
    Rem 保護の設定・解除の選択
    Dim 選択 As Long
    選択 = InputBox("処理を選択してください" & vbCrLf & vbCrLf & "保護 = 1  解除 = 2")
    
    On Error GoTo 0
    
    Rem パスワードの入力
    Dim GetPW As String
    GetPW = InputBox("パスワードを入力してください")
    
    Select Case 選択
        Case 1
            Call 保護(GetPW)
        Case 2
            Call 保護解除(GetPW)
    End Select
    
    Exit Sub
    
キャンセル処理:
    MsgBox "キャンセルしました"
    
End Sub

Sub 保護(ByVal PW As String)
    
    Rem シートの保護
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Protect Password:=PW, UserInterfaceOnly:=True     'マクロでの操作は許可
    Next
    
    Rem ブックの保護
    ActiveWorkbook.Protect Password:=PW, Structure:=True, Windows:=False
    
End Sub

Sub 保護解除(ByVal PW As String)
    
    Rem シートの保護解除
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Unprotect Password:=PW
    Next
    
    Rem ブックの保護解除
    ActiveWorkbook.Unprotect Password:=PW
    
End Sub

Sub 処理時間計測()
    
    Rem 計測開始
    Dim 開始時間 As Single
    開始時間 = Timer
    
    Rem 計測終了
    Dim 終了時間 As Single
    終了時間 = Timer
    
    MsgBox "完了！" & vbCrLf & vbCrLf & "処理時間：" & Round(終了時間 - 開始時間, 2) & "秒"
    
End Sub

’ブックモジュールに記述

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim shpCat          As Shape        '動作する画像
    Dim shpAroundRng    As Range        'ShpCatの配置されているセル範囲
    Dim appearRng       As Range        'ShpCatが出現するセル
    Dim activeRng       As Range        'ActiveCellを保持するための変数
    Dim SelectRng       As Range        'Selectionを保持するための変数
    Dim visiRng         As Range        '現在画面に表示されているセル範囲
    
    Set visiRng = ActiveWindow.VisibleRange
    Set activeRng = ActiveCell
    Set SelectRng = Selection
    
    
    Application.EnableEvents = False
    
    Set shpCat = getShp(shpName:="cat")
    Call delShp(shpName:="テキスト")
    
    If Not shpCat Is Nothing Then
        
        Set shpAroundRng = shpCat.Parent.Range(shpCat.TopLeftCell, shpCat.BottomRightCell)
        Set appearRng = getAppearRng(visiRng)
        Select Case True
            Case shpCat.Parent.Name <> Sh.Name, Intersect(visiRng, shpAroundRng) Is Nothing '画面内にShpCatが無ければ、shpCatをカットしappearRngに貼り付ける
                shpCat.Cut
                appearRng.Select
                Sh.Paste
                Set shpCat = Sh.Shapes(Selection.Name)
                Target.Select
        End Select
        
        
        Call 猫寄ってくる(activeRng, shpCat)
        
    End If
    
    SelectRng.Select
    Application.EnableEvents = True
    
End Sub


Private Function getShp(ByVal shpName As String) As Shape
    '名前がShpNameのShapeがSetされ次第関数を抜ける
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        Set getShp = ws.Shapes(shpName)
        If Err.Number = 0 Then Exit For
        Err.Clear
    Next

End Function

Private Sub delShp(ByVal shpName As String)
    'ブック内の全てのShpNameのShapeを削除する
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        ws.Shapes(shpName).Delete
    Next

End Sub

Private Function getAppearRng(ByVal rng As Range) As Range
    '引数rngの四隅(の一つ内側)のセルの内いずれかをランダムで返す関数
    '1:左上
    '2:右上
    '3:左下
    '4:右下
    
    Randomize
    Dim rndNum As Long
    rndNum = Int(Rnd * 4) + 1
    
    Select Case rndNum
        Case 1:     Set getAppearRng = rng(1).Offset(1, 1)
        Case 2:     Set getAppearRng = rng.Offset(, rng.Columns.Count - 1).Item(1).Offset(1, -1)
        Case 3:     Set getAppearRng = rng.Offset(rng.Rows.Count - 1).Item(1).Offset(-1, 1)
        Case 4:     Set getAppearRng = rng(rng.Count).Offset(-1, -1)
    End Select
        
    
End Function


Private Sub 猫寄ってくる(ByVal rng As Range, ByVal shp As Shape)
    'shpの縦位置がrngの縦位置に達するまで縦移動し続ける
    'shpの横位置がrngの横位置に達するまで横移動し続ける
    'shpとrngの位置が一致したらループを抜ける
    
    Dim sphCenterV      As Double   'shpの縦中央位置
    Dim sphCenterH      As Double   'shpの横中央位置
    Dim rngCenterV      As Double   'rngの縦中央位置
    Dim rngCenterH      As Double   'rngの横中央位置
    Dim beforeShpArea   As String   'shpの1ステップ移動前位置
    Dim afterShpArea    As String   'shpの1ステップ移動後位置
    Dim flgV            As Boolean  'shpの縦位置がrngの縦位置に達したらTrueにする
    Dim flgH            As Boolean  'shpの横位置がrngの横位置に達したらTrueにする
    Const speed As Double = 6
    
    rngCenterV = rng.Top + rng.Height / 2
    rngCenterH = rng.Left + rng.Width / 2
    
    Do
        DoEvents
        
        sphCenterV = shp.Top + shp.Height / 2
        sphCenterH = shp.Left + shp.Width / 2
        
        beforeShpArea = shp.Top & "|" & shp.Left
        If Not flgV Then shp.Top = IIf(sphCenterV - rngCenterV < 0, shp.Top + speed, shp.Top - speed)
        If Not flgH Then shp.Left = IIf(sphCenterH - rngCenterH < 0, shp.Left + speed, shp.Left - speed)
        afterShpArea = shp.Top & "|" & shp.Left
        
        
        If Abs(sphCenterV - rngCenterV) < speed Then flgV = True
        If Abs(sphCenterH - rngCenterH) < speed Then flgH = True
        
        If flgV And flgH Then Exit Do
        If afterShpArea = beforeShpArea Then Exit Do
        
        Application.Wait [Now()] + 0.001 / 86400
    Loop
    
    
    Call にゃーと鳴く(shp, shp.Parent)
    
    
    
End Sub



Private Sub にゃーと鳴く(ByVal shp As Shape, ByVal ws As Worksheet)
    'shpの右隣にテキストボックスを配置して「にゃーー」と入力するにゃ。
    
    Dim テキストTop     As Double
    Dim テキストleft    As Double
    Dim テキスト        As Shape
    
    テキストTop = shp.Top
    テキストleft = shp.Left + shp.Width

    ws.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=テキストleft, _
            Top:=テキストTop, _
            Width:=100, _
            Height:=60).Select
    
    With Selection
        .Name = "テキスト"
        .ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
        .ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.Fill.ForeColor.RGB = 11854022
        .ShapeRange.Line.ForeColor.RGB = 0
        .ShapeRange.TextFrame.Characters.Text = "にゃーー"
        .ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
        .ShapeRange.TextFrame2.TextRange.Font.Size = 16
    End With
    
End Sub

'ブックモジュールに記述

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim shpCat          As Shape        '動作する画像
    Dim shpAroundRng    As Range        'ShpCatの配置されているセル範囲
    Dim appearRng       As Range        'ShpCatが出現するセル
    Dim activeRng       As Range        'ActiveCellを保持するための変数
    Dim visiRng         As Range        '現在画面に表示されているセル範囲
    Set visiRng = ActiveWindow.VisibleRange
    Set activeRng = ActiveCell
    
    Application.EnableEvents = False
    
    Set shpCat = getShp(shpName:="cat")
    Call delShp(shpName:="テキスト")
    
    If Not shpCat Is Nothing Then
        
        Set shpAroundRng = shpCat.Parent.Range(shpCat.TopLeftCell, shpCat.BottomRightCell)
        Set appearRng = getAppearRng(visiRng)
        Select Case True
            Case shpCat.Parent.Name <> Sh.Name, Intersect(visiRng, shpAroundRng) Is Nothing '画面内にShpCatが無ければ、shpCatをカットしappearRngに貼り付ける
                shpCat.Cut
                appearRng.Select
                Sh.Paste
                Set shpCat = Sh.Shapes(Selection.Name)
                Target.Select
        End Select
        
        
        Call 猫寄ってくる(activeRng, shpCat)
        
    End If
    
    activeRng.Select
    Application.EnableEvents = True
    
End Sub


Private Function getShp(ByVal shpName As String) As Shape
    '名前がShpNameのShapeがSetされ次第関数を抜ける
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        Set getShp = ws.Shapes(shpName)
        If Err.Number = 0 Then Exit For
        Err.Clear
    Next

End Function

Private Sub delShp(ByVal shpName As String)
    'ブック内の全てのShpNameのShapeを削除する
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        ws.Shapes(shpName).Delete
    Next

End Sub

Private Function getAppearRng(ByVal rng As Range) As Range
    '引数rngの四隅(の一つ内側)のセルの内いずれかをランダムで返す関数
    '1:左上
    '2:右上
    '3:左下
    '4:右下
    
    Randomize
    Dim rndNum As Long
    rndNum = Int(Rnd * 4) + 1
    
    Select Case rndNum
        Case 1:     Set getAppearRng = rng(1).Offset(1, 1)
        Case 2:     Set getAppearRng = rng.Offset(, rng.Columns.Count - 1).Item(1).Offset(1, -1)
        Case 3:     Set getAppearRng = rng.Offset(rng.Rows.Count - 1).Item(1).Offset(-1, 1)
        Case 4:     Set getAppearRng = rng(rng.Count).Offset(-1, -1)
    End Select
        
    
End Function


Private Sub 猫寄ってくる(ByVal rng As Range, ByVal shp As Shape)
    'shpの縦位置がrngの縦位置に達するまで縦移動し続ける
    'shpの横位置がrngの横位置に達するまで横移動し続ける
    'shpとrngの位置が一致したらループを抜ける
    
    Dim sphCenterV      As Double   'shpの縦中央位置
    Dim sphCenterH      As Double   'shpの横中央位置
    Dim rngCenterV      As Double   'rngの縦中央位置
    Dim rngCenterH      As Double   'rngの横中央位置
    Dim beforeShpArea   As String   'shpの1ステップ移動前位置
    Dim afterShpArea    As String   'shpの1ステップ移動後位置
    Dim flgV            As Boolean  'shpの縦位置がrngの縦位置に達したらTrueにする
    Dim flgH            As Boolean  'shpの横位置がrngの横位置に達したらTrueにする
    Const speed As Double = 6
    
    rngCenterV = rng.Top + rng.Height / 2
    rngCenterH = rng.Left + rng.Width / 2
    
    Do
        DoEvents
        
        sphCenterV = shp.Top + shp.Height / 2
        sphCenterH = shp.Left + shp.Width / 2
        
        beforeShpArea = shp.Top & "|" & shp.Left
        If Not flgV Then shp.Top = IIf(sphCenterV - rngCenterV < 0, shp.Top + speed, shp.Top - speed)
        If Not flgH Then shp.Left = IIf(sphCenterH - rngCenterH < 0, shp.Left + speed, shp.Left - speed)
        afterShpArea = shp.Top & "|" & shp.Left
        
        
        If Abs(sphCenterV - rngCenterV) < speed Then flgV = True
        If Abs(sphCenterH - rngCenterH) < speed Then flgH = True
        
        If flgV And flgH Then Exit Do
        If afterShpArea = beforeShpArea Then Exit Do
        
        Application.Wait [Now()] + 0.001 / 86400
    Loop
    
    
    Call にゃーと鳴く(shp, shp.Parent)
    
    
    
End Sub



Private Sub にゃーと鳴く(ByVal shp As Shape, ByVal ws As Worksheet)
    'shpの右隣にテキストボックスを配置して「にゃーー」と入力するにゃ。
    
    Dim テキストTop     As Double
    Dim テキストleft    As Double
    Dim テキスト        As Shape
    
    テキストTop = shp.Top
    テキストleft = shp.Left + shp.Width

    ws.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=テキストleft, _
            Top:=テキストTop, _
            Width:=100, _
            Height:=60).Select
    
    With Selection
        .Name = "テキスト"
        .ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
        .ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.Fill.ForeColor.RGB = 11854022
        .ShapeRange.Line.ForeColor.RGB = 0
        .ShapeRange.TextFrame.Characters.Text = "にゃーー"
        .ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
        .ShapeRange.TextFrame2.TextRange.Font.Size = 16
    End With
    
End Sub

Option Explicit

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
     Source As Any, _
     ByVal Length As LongPtr)
Sub test()
    
    Dim strA As String
    Dim strB As String
    Dim btA(3) As Byte
    Dim btB(3) As Byte
    Dim i As Long
    
    strA = "AAAAAAAAAAAAAAAA"
    
    'VarPtr(strA)とはstrAの文字列の実体が置かれているアドレスが書かれているアドレス。
    '以下を実施することでstrBの文字列の実体が置かれているアドレスが書かれているアドレスに
    'strAの実体が置かれているアドレスが書き込まれる。
    Call CopyMemory(ByVal VarPtr(strB), ByVal VarPtr(strA), 4)
    
    'Midステートメントの実施
    Mid(strA, 3, 2) = "BB"
        
    'strAに変更を加えたのにstrBにも影響が
    Debug.Print "両者の文字列を表示"
    Debug.Print strA
    Debug.Print strB
    
    '文字列の実体が書かれているアドレスを取得
    Call CopyMemory(btA(0), ByVal VarPtr(strA), 4)
    Call CopyMemory(btB(0), ByVal VarPtr(strB), 4)
    
    '同じ文字列の実体を指し示している2つの変数なのでstrBにも影響が出るのは当然
    'Midステートメントは文字列の実体を操作しているだけと想像できる
    Debug.Print vbCr & "両者の文字列の実体のアドレス"
    For i = 0 To 3
        Debug.Print Hex(btA(i)) & " ";
    Next i
    Debug.Print ""
    For i = 0 To 3
        Debug.Print Hex(btB(i)) & " ";
    Next i
    Debug.Print ""
    
    'Midステートメントのやっていることを想像
    '3文字目は先頭アドレス＋4バイト目（1文字目0バイト1バイト、2文字目2バイト3バイト）
    'どこかに用意した"BB"のアドレスから2文字（4バイト分）
    'Call CopyMemory(ByVal StrPtr(strA) + 4, ByVal StrPtr("BB"), 4)
    '↑Midステートメントの代わりにMidステートメントと同じ場所で実施すれば同じ結果となる
    
    'Replace
    strA = Replace(strA, "BB", "CC")
    
    '今度はstrBには影響しない
    Debug.Print vbCr & "両者の文字列を表示"
    Debug.Print strA
    Debug.Print strB
    
    '文字列の実体が書かれているアドレスを取得
    Call CopyMemory(btA(0), ByVal VarPtr(strA), 4)
    Call CopyMemory(btB(0), ByVal VarPtr(strB), 4)
    
    '違う文字列の実体を指し示している。
    'Replaceのコードを見れば、strAに代入してしまったので別の文字列の実体を指し示すようになったということ。
    Debug.Print vbCr & "両者の文字列の実体のアドレス"
    For i = 0 To 3
        Debug.Print Hex(btA(i)) & " ";
    Next i
    Debug.Print ""
    For i = 0 To 3
        Debug.Print Hex(btB(i)) & " ";
    Next i
    Debug.Print ""
    
    '文字数を取得（文字列の実体より前4バイトで文字数を表す）
    Dim btC(3) As Byte
    Call CopyMemory(btC(0), ByVal StrPtr(strA) - 4, 4)
    
    'リトルエンディアンで20＝32バイト＝16文字と分かる
    Debug.Print vbCr & "strAの文字数を取得"
    For i = 0 To 3
        Debug.Print Hex(btC(i)) & " ";
    Next i
    Debug.Print ""
    
    'こんなことしちゃって良いの？
    '文字数変更で8文字（16バイト)
    btC(0) = 16
    Call CopyMemory(ByVal StrPtr(strA) - 4, btC(0), 4)
    
    Debug.Print vbCr & "8文字に変更したstrAの表示"
    Debug.Print strA
    
    '終端が00じゃ無いんですけど！！（16バイト目が00になっていない）
    Dim btD(31) As Byte
    Call CopyMemory(btD(0), ByVal StrPtr(strA), 32)
    Debug.Print vbCr & "strAの8文字とstrAより後の8文字を表示"
    Debug.Print btD
    Debug.Print "↑strAの終端が00じゃ無いんですけど！！"
    
End Sub

'ブックモジュール
Option Explicit

Private Sub Workbook_Open()
    Application.OnKey "+^{c}", "inTotal"
    Application.OnKey "+^{+}", "plusTotal"
    Application.OnKey "+^{v}", "outTotal"
    Application.OnKey "+^{*}", "clearTotal"
End Sub


'標準モジュール
Option Explicit

Dim stackSum As Variant

Sub inTotal()
    stackSum = CDec(WorksheetFunction.Sum(Selection))
    Call showStatusBer(stackSum)
End Sub

Sub plusTotal()
    stackSum = stackSum + CDec(WorksheetFunction.Sum(Selection))
    Call showStatusBer(stackSum)
End Sub


Sub outTotal()
    Selection.Value = stackSum
End Sub

Sub clearTotal()
    stackSum = 0
    Application.StatusBar = False
End Sub

Sub showStatusBer(ByVal num As Variant)
    Dim len小数部 As Long:  len小数部 = Len(CStr(num)) - Len(CStr(Int(num))) - 1
    
    If len小数部 <= 0 Then
        Application.StatusBar = "Total = " & Format(num, "#,##0")
    Else
        Application.StatusBar = "Total = " & Format(num, "#,##0." & String(len小数部, "0"))
    End If

End Sub