MakeSpinButtonUpDown

'MakeSpinButtonUpDown   ・・・元場所：IkiAddin.ModOther
'MakeSpinButtonLeftRight・・・元場所：IkiAddin.ModOther
'Make__SpinButton       ・・・元場所：IkiAddin.ModOther
'GetSelectionCell       ・・・元場所：IkiAddin.ModCell
'OffsetCell             ・・・元場所：IkiAddin.ModCell
'F_InputBox             ・・・元場所：IkiAddin.ModMessage
'GetCellName            ・・・元場所：IkiAddin.ModCell
'AddCodeToModule        ・・・元場所：IkiAddin.ModVBIDE
'GetAllCodeModuleInBook ・・・元場所：IkiAddin.ModVBIDE
'ChangeValueCell        ・・・元場所：IkiAddin.ModCell

Public Sub MakeSpinButtonUpDown()
'▲▼のスピンボタンを設置する
'20241105

    Call Make__SpinButton(True)
End Sub

Public Sub MakeSpinButtonLeftRight()
'左右のスピンボタンを設置する
'20241105

    Call Make__SpinButton(False)
End Sub

Private Sub Make__SpinButton(Opt_UpDown As Boolean)
'セル範囲にスピンボタンを設置して、次に選択セルの値を上下させる
'20241104

'https://gist.github.com/YujiFukami/868da9ce536aa3563a6d0208f5229c9c

    '選択セル取得
    Dim SelectCell As Range: Set SelectCell = GetSelectionCell
    If SelectCell Is Nothing Then Exit Sub
    
    '増減対象のセルを選択
    Dim DefaultCell As Range: Set DefaultCell = OffsetCell(SelectCell(1), 0, -1)
    Dim targetCell  As Range: Set targetCell = F_InputBox("値の増減対象のセルを選択してください", "増減対象セル選択", DefaultCell.address, , , , , True)
    If targetCell Is Nothing Then Exit Sub
    If targetCell.CountLarge > 1 Then
        MsgBox "増減対象のセルは単一セルを選択してください", vbExclamation
        Exit Sub
    End If
    
    '▲▼ボタンを設置
    Dim Sheet      As Worksheet: Set Sheet = SelectCell.Worksheet
    Dim ButtonUp   As Button
    Dim ButtonDown As Button
    
    If Opt_UpDown = True Then 'スピンボタンが上下方向の場合
        Set ButtonUp = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top, SelectCell.Width, SelectCell.Height / 2)
        Set ButtonDown = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top + SelectCell.Height / 2, SelectCell.Width, SelectCell.Height / 2)
        ButtonUp.Text = "▲"
        ButtonDown.Text = "▼"
    Else
        Set ButtonDown = Sheet.Buttons.Add(SelectCell.Left, SelectCell.Top, SelectCell.Width / 2, SelectCell.Height)
        Set ButtonUp = Sheet.Buttons.Add(SelectCell.Left + SelectCell.Width / 2, SelectCell.Top, SelectCell.Width / 2, SelectCell.Height)
        ButtonUp.Text = ChrW(9654) '右三角形
        ButtonDown.Text = ChrW(9664) '左三角形
    End If
    
    '値の上限、下限、変化量を入力
    Dim Step           As Double: Step = F_InputBox("値の変化量を入力してください", "変化量入力", 1, , True)
    Dim MinValue_Input As Variant: MinValue_Input = F_InputBox("値の最小値を入力してください", "最小値入力", , , True)
    Dim MaxValue_Input As Variant: MaxValue_Input = F_InputBox("値の最大値を入力してください", "最大値入力", , , True)
    
    'コード作成
    Dim SheetCodeName      As String: SheetCodeName = Sheet.CodeName
    Dim CellName           As String: CellName = GetCellName(targetCell)
    If CellName = "" Then CellName = targetCell.address(False, False)
    Dim MaxValue           As Double
    Dim MinValue           As Double
    Dim StrCodeUp          As String
    Dim StrCodeDown        As String
    Dim ProcedureName_Up   As String: ProcedureName_Up = "ChangeValue" & SheetCodeName & CellName & "Up"
    Dim ProcedureName_Down As String: ProcedureName_Down = "ChangeValue" & SheetCodeName & CellName & "Down"
    StrCodeUp = StrCodeUp & "Public Sub " & ProcedureName_Up & "()" & vbLf
    StrCodeUp = StrCodeUp & "    Dim Target   As Range:  Set Target = " & SheetCodeName & ".Range(" & """" & CellName & """" & ")" & vbLf
    StrCodeUp = StrCodeUp & "    Dim Step     As Double: Step = " & Step & vbLf
    
    StrCodeDown = StrCodeDown & "Public Sub " & ProcedureName_Down & "()" & vbLf
    StrCodeDown = StrCodeDown & "    Dim Target   As Range:  Set Target = " & SheetCodeName & ".Range(" & """" & CellName & """" & ")" & vbLf
    StrCodeDown = StrCodeDown & "    Dim Step     As Double: Step = " & Step & vbLf
    
    If TypeName(MaxValue_Input) <> "Boolean" And TypeName(MinValue_Input) <> "Boolean" Then
        MaxValue = Val(MaxValue_Input)
        MinValue = Val(MinValue_Input)
        StrCodeUp = StrCodeUp & "    Dim MaxValue As Double: MaxValue = " & MaxValue & vbLf
        StrCodeUp = StrCodeUp & "    Dim MinValue As Double: MinValue = " & MinValue & vbLf
        StrCodeUp = StrCodeUp & "    Call ChangeValueCell(Target, Step, True, MaxValue, MinValue)" & vbLf
        
        StrCodeDown = StrCodeDown & "    Dim MaxValue As Double: MaxValue = " & MaxValue & vbLf
        StrCodeDown = StrCodeDown & "    Dim MinValue As Double: MinValue = " & MinValue & vbLf
        StrCodeDown = StrCodeDown & "    Call ChangeValueCell(Target, Step, False, MaxValue, MinValue)" & vbLf
    
    ElseIf TypeName(MaxValue_Input) = "Boolean" And TypeName(MinValue_Input) <> "Boolean" Then
        MinValue = Val(MinValue_Input)
        StrCodeUp = StrCodeUp & "    Dim MinValue As Double: MinValue = " & MinValue & vbLf
        StrCodeUp = StrCodeUp & "    Call ChangeValueCell(Target, Step, True, , MinValue)" & vbLf
    
        StrCodeDown = StrCodeDown & "    Dim MinValue As Double: MinValue = " & MinValue & vbLf
        StrCodeDown = StrCodeDown & "    Call ChangeValueCell(Target, Step, False, , MinValue)" & vbLf
        
    ElseIf TypeName(MaxValue_Input) <> "Boolean" And TypeName(MinValue_Input) = "Boolean" Then
        MaxValue = Val(MaxValue_Input)
        StrCodeUp = StrCodeUp & "    Dim MaxValue As Double: MaxValue = " & MaxValue & vbLf
        StrCodeUp = StrCodeUp & "    Call ChangeValueCell(Target, Step, True, MaxValue)" & vbLf
    
        StrCodeDown = StrCodeDown & "    Dim MaxValue As Double: MaxValue = " & MaxValue & vbLf
        StrCodeDown = StrCodeDown & "    Call ChangeValueCell(Target, Step, False, MaxValue)" & vbLf
    
    Else
        StrCodeUp = StrCodeUp & "    Call ChangeValueCell(Target, Step, True)" & vbLf
    
        StrCodeDown = StrCodeDown & "    Call ChangeValueCell(Target, Step, False)" & vbLf
    
    End If
    
    StrCodeUp = StrCodeUp & "End Sub" & vbLf
    StrCodeDown = StrCodeDown & "End Sub" & vbLf
    
    'コード自動作成
    Dim Book As Workbook: Set Book = ActiveWorkbook
    Call AddCodeToModule(Sheet.CodeName, StrCodeUp, Book)
    Call AddCodeToModule(Sheet.CodeName, StrCodeDown, Book)
    
    'ボタンにマクロの登録
    ButtonUp.OnAction = "'" & Book.Name & "'!" & Sheet.CodeName & "." & ProcedureName_Up
    ButtonDown.OnAction = "'" & Book.Name & "'!" & Sheet.CodeName & "." & ProcedureName_Down
'    ButtonUp.OnAction = "'" & Book.Name & "'!" & Sheet.Name & "." & ProcedureName_Up
'    ButtonDown.OnAction = "'" & Book.Name & "'!" & Sheet.Name & "." & ProcedureName_Down
    
End Sub

Private Function GetSelectionCell() As Range
'選択中のセルを取得する
'セル以外を選択している場合はNothingを返す
'20220312
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35129752.html
    
    '処理
    Dim Dummy  As Object: Set Dummy = Selection
    Dim Output As Range: Set Output = Nothing
    If TypeName(Dummy) = "Range" Then
        Set Output = Dummy
    End If
    
    '出力
    Set GetSelectionCell = Output
End Function

Private Function OffsetCell(ByRef Cell As Range, _
             Optional ByRef RowOffset As Long = 0, _
             Optional ByRef ColOffset As Long = 0) _
                                      As Range
'Range.Offsetプロパティの直感に反する処理を解消
'セル結合の影響を排除する
'20230127
    
'引数
'Cell       ・・・基準セル
'[RowOffset]・・・下方向のオフセット量
'[ColOffset]・・・右方向のオフセット量
    
    If Cell Is Nothing Then Exit Function
    
    '処理
    Dim Sheet  As Worksheet
    Set Sheet = Cell.Worksheet
    
    Dim Output As Range
    Set Output = Sheet.Cells(Cell.Row + RowOffset, _
                             Cell.Column + ColOffset)
    
    '出力
    Set OffsetCell = Output
    
End Function

Private Function F_InputBox(ByRef Prompt As String, _
                   Optional ByRef Title As String, _
                 Optional ByRef Default As String, _
                 Optional ByRef Formula As Boolean = False, _
                   Optional ByRef Value As Boolean = False, _
                 Optional ByRef String_ As Boolean = False, _
                Optional ByRef Boolean_ As Boolean = False, _
                 Optional ByRef RefCell As Boolean = False, _
                   Optional ByRef Error As Boolean = False, _
                  Optional ByRef Array_ As Boolean = False) As Variant
'Application.InputBoxのType引数の処理を個別に指定できる
'20211222
'20220118修正
'20220317改良
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35111320.html

'引数
'Prompt    ・・・表示メッセージ
'[Title]   ・・・タイトル
'[Default] ・・・デフォルト値
'[Formula] ・・・数式かどうか
'[Value]   ・・・数値かどうか
'[String_] ・・・文字列かどうか
'[Boolean_]・・・ブール値かどうか
'[RefCell] ・・・セル参照かどうか
'[Error]   ・・・エラー値かどうか
'[Array_]  ・・・値の配列かどうか

    'InputBoxのType引数を計算する
    Dim TypeNum As Long: TypeNum = 0
    If Formula Then TypeNum = TypeNum + 0
    If Value Then TypeNum = TypeNum + 1
    If String_ Then TypeNum = TypeNum + 2
    If Boolean_ Then TypeNum = TypeNum + 4
    If RefCell Then TypeNum = TypeNum + 8
    If Error Then TypeNum = TypeNum + 16
    If Array_ Then TypeNum = TypeNum + 64
    
    If TypeNum = 0 Then
        TypeNum = 2 'デフォルトでは文字列とする
    End If
    
    If RefCell = True Then
        Set F_InputBox = Nothing '20220317(セル選択にてキャンセルとなった場合はNothingを返す処理)
        On Error Resume Next
        If Default <> "" Then
            Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default)
        Else
            Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum)
        End If
        On Error GoTo 0
    Else
        If Default <> "" Then
            F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default)
        Else
            F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum)
        End If
    End If
    
End Function

Private Function GetCellName(Cell As Range) As String
'セルに定義されている名前を取得する
'20241104
    
'引数
'Cell・・・対象セル
    
    Dim Output As String
    On Error Resume Next
    Output = Cell.Name
    On Error GoTo 0
    
    If Output <> "" Then
        Output = Cell.Name.Name
        If InStr(Output, "!") > 0 Then
            Output = Split(Output, "!")(1)
        End If
    Else
        Output = Cell.address(False, False)
    End If
    
    GetCellName = Output
    
End Function

Private Sub AddCodeToModule(ByRef ModuleName As String, _
                              ByRef CodeStr As String, _
                        Optional ByRef Book As Workbook)
'指定のモジュールの終端にコードを追加する
'20230808

'引数
'ModuleName・・・モジュール名
'CodeStr   ・・・追加するコード
'[Book]    ・・・対象ブック/省略ならActiveWorkbook

    If Book Is Nothing Then
        Set Book = ActiveWorkbook
    End If
    
    Dim Dict_Component As Dictionary:  Set Dict_Component = GetAllCodeModuleInBook(Book)
    Dim Component      As VBComponent: Set Component = Dict_Component(ModuleName)
    
    'コード行数取得
    Dim CountOfLine As Long: CountOfLine = Component.CodeModule.CountOfLines + 1
    
    'コード追加
    Call Component.CodeModule.InsertLines(CountOfLine, CodeStr)
    
End Sub

Private Function GetAllCodeModuleInBook(Book As Workbook) As Dictionary
'指定ブックの全VBComponentを取得して連想配列に格納
'20230808

'引数
'Book・・・対象ブック

    Dim Project   As VBProject: Set Project = Book.VBProject 'ブックのVBProject
    Dim Component As VBComponent
    Dim Output    As New Dictionary
    For Each Component In Project.VBComponents
        Output.Add Component.Name, Component
    Next
        
    Set GetAllCodeModuleInBook = Output
End Function

Public Sub ChangeValueCell(ByRef target As Range, _
                             ByRef Step As Double, _
                          ByRef Up_True As Boolean, _
                Optional ByRef MaxValue As Double = -9999, _
                Optional ByRef MinValue As Double = -9999)
'特定のセルの値を増減させる
'20241104

'引数
'Target    ・・・増減対象のセル
'Step      ・・・増減値
'Up_True   ・・・増加させるならTrue、減少させるならFalse
'[MaxValue]・・・増減の最大値
'[MinValue]・・・増減の最小値

    Dim NowValue As Double: NowValue = target.Value
    
    If Up_True = True Then
        If Step > 0 Then
            If MaxValue <> -9999 Then
                If NowValue + Step <= MaxValue Then
                    target.Value = NowValue + Step
                End If
            Else
                target.Value = NowValue + Step
            End If
        Else
            If MinValue <> -9999 Then
                If NowValue + Step >= MinValue Then
                    target.Value = NowValue + Step
                End If
            Else
                target.Value = NowValue + Step
            End If
        End If
    Else
        If Step > 0 Then
            If MinValue <> -9999 Then
                If NowValue - Step >= MinValue Then
                    target.Value = NowValue - Step
                End If
            Else
                target.Value = NowValue - Step
            End If
        Else
            If MaxValue <> -9999 Then
                If NowValue - Step <= MaxValue Then
                    target.Value = NowValue - Step
                End If
            Else
                target.Value = NowValue - Step
            End If
        End If
    End If
    
End Sub