Option Explicit

Sub Meikyuu()

    ' #VBA100本ノック 迷宮編

    Dim x       As Long, y As Long, ny As Long, nx As Long ' セル位置座標用
    Dim Bx      As Long, By As Long, Bnx As Long, Bny As Long   ' 5×5ブロック単位範囲用
    Dim ForY    As Long, ForX As Long, ForXS As Long, ForXE As Long, xStep As Long
    Dim i       As Long, iss As Long, ie As Long, iStep As Long
    Dim j       As Long, js As Long, je As Long, jStep As Long
    Dim Kyori   As Double, stKyori As Double               ' 直線距離計算用
    Dim Flg     As Boolean                                 ' 最短距離フラグ
    Dim Arr     As Variant                                 ' セル値ストック用配列
    
    Range("A1:O15").ClearContents: Range("A1").Select      ' シートクリア
    x = 1: y = 1                ' スタート位置セット
    
    ' 5×5のブロック単位でサーチ
    For ForY = 1 To 11 Step 5
        ' 横位置は左右スタート位置が交互にする設定
        If ForY = 6 Then ForXS = 11: ForXE = 1: xStep = -5 Else ForXS = 1: ForXE = 11: xStep = 5
        ' ブロック単位サーチ
        For ForX = ForXS To ForXE Step xStep
            ' ブロック内左右サーチはプロック左右進行方向に合わせる
            If ForY = 6 Then iss = 4: ie = 0: iStep = -1 Else iss = 0: ie = 4: iStep = 1
            For Bx = iss To ie Step iStep
                ' ブロック内上下は前回通過点に近い方からスタートし、交互に上下
                If x Mod 5 = 0 Or x Mod 5 = 4 Then js = 4: je = 0: jStep = -1 Else js = 0: je = 4: jStep = 1
                For By = js To je Step jStep
                    If Cells(ForY + By, ForX + Bx).Interior.Color = vbYellow Then
                        Call Marking(y, x, ForY + By, ForX + Bx)    ' ルートマーキング処理へ
                        y = ForY + By: x = ForX + Bx
                    End If
                Next
            Next
        Next
    Next
    
    Call Marking(y, x, 15, 15)    ' 最終黄色地点から終点まで
    
End Sub

Sub Marking(y As Long, x As Long, ny As Long, nx As Long)

    Dim stPos As Long, i As Long, sStep As Long
    Dim Flg     As Boolean  ' 通過で出来ずフラグ
    Dim stArr   As Variant  ' セル値ストック用配列
    
    stArr = Range("A1:O15").Value ' 最初のセル状態ストック
    
    ' 【地点間の通過済でないルート探索（縦位置スタートから試み、駄目なら次に横位置スタート）】
    Flg = True
    ' 縦 → 横 探索
    ' 最初に縦位置探索（既に通過済と交わればフラグOFF）
    If y <= ny Then sStep = 1 Else sStep = -1
    Cells(y, x).Value = "" ' スタート位置クリア
    For i = y To ny Step sStep
        If Cells(i, x).Value <> "" Then Flg = False
        Cells(i, x).Value = "●"
    Next
    
    ' 次に横位置探索（既に通過済と交わればフラグOFF）
    If x <= nx Then sStep = 1 Else sStep = -1
    Cells(ny, x).Value = "" ' スタート位置クリア
    For i = x To nx Step sStep
        If Cells(ny, i).Value <> "" Then Flg = False
        Cells(ny, i).Value = "●"
    Next
    
    ' 既に通過済みと交差してなければ戻る
    If Flg Then Exit Sub
    
    Range("A1:O15") = stArr ' 前の状態をクリア
    Flg = True
    ' 横 → 縦 探索
    ' 最初に横位置探索（既に通過済と交わればフラグOFF）
    If x <= nx Then sStep = 1 Else sStep = -1
    Cells(i, y).Value = "" ' スタート位置クリア
    For i = x To nx Step sStep
        If Cells(y, i).Value <> "" Then Flg = False
        Cells(y, i).Value = "●"
    Next
    ' 次に縦位置探索（既に通過済と交わればフラグOFF）
    If y <= ny Then sStep = 1 Else sStep = -1
    Cells(y, nx).Value = ""     ' スタート位置クリア
    For i = y To ny Step sStep  ' 次に横位置
        If Cells(i, nx).Value <> "" Then Flg = False
        Cells(i, nx).Value = "●"
    Next

End Sub

Sub 年月別にフォルダを作成_xlsx()

'処理時間の計測-----------------------------------------------------------------------------------
Dim startTime As Double
Dim endTime As Double
Dim processTime As Double

startTime = Timer
'__________________________________________________________________________________________________


Dim targetFolder As String
Dim loadFolder As String

targetFolder = ThisWorkbook.Path & "\" & "写真を仕分けて格納"
loadFolder = ThisWorkbook.Path & "\" & "処理対象写真を格納する"


Dim fso_lord, fso_traget As Object
Set fso_lord = CreateObject("scripting.filesystemobject")
Set fso_traget = CreateObject("scripting.filesystemobject")

Set f = fso_lord.GetFolder(loadFolder)
Set f2 = fso_traget.GetFolder(targetFolder)
Set fc = f.Files


'ファイル数が０なら処理終了。
If fc.Count = 0 Then MsgBox "対象ファイルなし": Exit Sub


'主処理
For Each f1 In fc

    '.jpgを処理。
    If f1.Name Like "*.xlsm" Or f1.Name Like "*.XLSM" Then
        '年、月を取得する。
        picture_date = FileDateTime(f1)
        picture_year = Year(picture_date)
        picture_month = Month(picture_date)
        FolderName = picture_year & "年" & picture_month & "月"
        SerchFolder = targetFolder & "\" & FolderName
        
        'フォルダが存在するか調べる
        If fso_traget.FolderExists(SerchFolder) Then
            '存在する場合は格納処理
            fso_lord.MoveFile f1, SerchFolder & "\"
            
        Else
            '存在しない場合は、フォルダを作って格納処理

            'フォルダ作成
            fso_traget.createfolder SerchFolder
            
            'ファイルを格納
            fso_lord.MoveFile f1, SerchFolder & "\"
            
        End If
        
    End If
Next f1


'処理時間の計測-----------------------------------------------------------------------------------
endTime = Timer
processTime = endTime - startTime

MsgBox "end 処理時間＝" & Round(processTime / 60, 0) & "分" & Round(processTime Mod 60, 0) & "秒"
'__________________________________________________________________________________________________


End Sub

Option Explicit

Sub Uranai()

    ' 相性を占いたい男女の名前をそれぞれ半角カタカナで設定してください。
    Dim S_Name      As String, S_Int       As String, S_Wk       As String
    Dim i           As Long
    Dim Man         As String: Man = "ﾆｼｼﾞﾏﾋﾃﾞﾄｼ"
    Dim Woman       As String: Woman = "ｱﾗｶﾞｷﾕｲ"
    
    ' 名前に濁音、ぱく音があれば消去し、並べて表示
    S_Name = Replace(Replace(Man & Woman, "ﾞ", ""), "ﾟ", ""): Debug.Print S_Name ' 名前を並べて表示
    
    ' 名前の数値化
    For i = 1 To Len(S_Name)
        If InStr("ｱｶｻﾀﾅﾊﾏﾔﾗﾜｧｬ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "1"    ' 母音アは 1
        If InStr("ｲｷｼﾁﾆﾋﾐﾘｨ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "2"       '     イは 2
        If InStr("ｳｸｽﾂﾇﾌﾑﾕﾙｩｭｯ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "3"    '     ウは 3
        If InStr("ｴｹｾﾃﾈﾍﾒﾚｪ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "4"       '     エは 4
        If InStr("ｵｺｿﾄﾉﾎﾓﾖﾛｦｫｮ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "5"    '     オは 5
        If InStr("ﾝ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "0"               '     ンは 0
    Next
    
    ' 100％以下になるまで計算を繰り返す
    Do
        Debug.Print S_Int   ' 数値の表示
        If S_Int = "100" Or Len(S_Int) < 3 Then Exit Do
        
        ' 隣り合う数値を足し、1桁目だけを再度並べていく
        S_Wk = ""
        For i = 1 To Len(S_Int) - 1
            S_Wk = S_Wk & Right(CStr(Val(Mid(S_Int, i, 1)) + Val(Mid(S_Int, i + 1, 1))), 1)
        Next
        S_Int = S_Wk
    Loop
    
    Debug.Print "二人の相性は " & S_Int; " ％です"

End Sub

Option Explicit
Public lngTrib(2)
Sub test1()
    
    Dim i As Long
    Dim j As Long
    Dim str1 As String
    Dim lngUB As Long
    Dim t As Single
    
    t = Timer
    
    Do
        '速度優先のため再帰にせず(一番古い所に新しい値を入れる）
        lngTrib(i Mod 3) = Trib(i)
        str1 = ""
        lngUB = UBound(lngTrib(i Mod 3))
        For j = 0 To lngUB
            If j = lngUB Then
                '最上位はそのまま文字列
                str1 = CStr(lngTrib(i Mod 3)(j)) & str1
            Else
                '下位は8桁
                str1 = Format(lngTrib(i Mod 3)(j), "00000000") & str1
            End If
        Next j
        
        '1000桁で抜ける
        If Len(str1) >= 1000 Then
            Debug.Print str1
            Exit Do
        End If
        i = i + 1
    Loop
    
    Debug.Print Timer - t
    
    
End Sub
Private Function Trib(n As Long) As Long()
    
    Dim lngTmp() As Long
    ReDim lngTmp(0) As Long
    If n = 0 Then
        lngTmp(0) = 0
    ElseIf n = 1 Then
        lngTmp(0) = 0
    ElseIf n = 2 Then
        lngTmp(0) = 1
    Else
        lngTmp() = ArrayPlus(lngTrib(0), lngTrib(1), lngTrib(2))
    End If
    Trib = lngTmp
    
End Function
'配列同士で足し算
Private Function ArrayPlus(ary1, ary2, ary3) As Long()
    
    Dim lngTmp() As Long
    Dim i As Long
    Dim dblTmp As Double
    Dim lngUB As Long
    
    lngUB = WorksheetFunction.Max(UBound(ary1), UBound(ary2), UBound(ary3))
    ReDim lngTmp(lngUB) As Long
    ReDim Preserve ary1(lngUB) As Long
    ReDim Preserve ary2(lngUB) As Long
    ReDim Preserve ary3(lngUB) As Long
    
    For i = 0 To lngUB
        dblTmp = ary1(i) + ary2(i) + ary3(i)

        If lngTmp(i) + dblTmp >= 100000000 Then
            lngTmp(i) = (lngTmp(i) + dblTmp) Mod 100000000
            If i = lngUB Then
                ReDim Preserve lngTmp(lngUB + 1) As Long
            End If
            lngTmp(i + 1) = (dblTmp - lngTmp(i)) / 100000000
        Else
            lngTmp(i) = lngTmp(i) + CLng(dblTmp)
        End If

    Next i
    
    ArrayPlus = lngTmp
    
End Function

Option Explicit

Type RecType
    Bucket As Integer   '処理するバケツ0or1
    OpeType As Integer  '処理：-1=両方空にする。0=満タンにする。1=空にする。2=相手が満タンになるまで入れる。
    Water(1) As Integer '処理した結果の水の量。0=Aバケツの水の量、1=Bバケツの水の量。
End Type

Dim Rec(100) As RecType '処理の記録。100回もあればいいかな。

Dim MinRec(100) As RecType  '回数がもっとも少ないパターンを保存する。
Dim NumOfMinRec As Integer

Dim Capa(1) As Integer  'バケツABのキャパ
Dim tgtL As Integer     '目標の量

Public Sub Main()
    Call OpeMain(3, 5, 4) 'Acapa, Bcapa, 目標量
End Sub

Private Sub OpeMain(aCapa As Integer, bCapa As Integer, tgtLittle As Integer)
'初期設定と再帰呼び出し。結果表示
    Dim i As Integer
    
    Capa(0) = aCapa
    Capa(1) = bCapa
    tgtL = tgtLittle
    NumOfMinRec = 100
    Call Operation(0, -1)   '初期化から開始

    '結果表示
    If NumOfMinRec < 100 Then
        Debug.Print "A容量=" & aCapa; "L,B容量=" & bCapa & "L"
        For i = 0 To NumOfMinRec
            If MinRec(i).OpeType <> -1 Then
                Debug.Print i & ":A=" & MinRec(i).Water(0) & "L, B=" & MinRec(i).Water(1) & "L:" & _
                            Choose(MinRec(i).Bucket + 1, "A", "B") & "を" & _
                            Choose(MinRec(i).OpeType + 1, "満タンにした。", "空にした。", "相手に入れた。")
            End If
        Next
    End If

End Sub

Private Sub Operation(ByVal n As Integer, Optional OpeType As Integer, Optional TgtAB As Integer)
'=============================================
'再帰処理
'引数：
'  n:Rec配列のn番目を利用。
'　OpeType:0=満タンにする。1=空にする。2=相手が満タンになるまで入れる。
'  TgtAB:0=Aバケツを対象、1=Bバケツが対象
'=============================================
    Dim i As Integer, j As Integer, k As Integer
    Dim ChangeFlag As Boolean

    If n > UBound(Rec) Then Exit Sub        '回数多いのであきらめ
    
    Rec(n).Bucket = TgtAB
    Rec(n).OpeType = OpeType
    
    ChangeFlag = False
    Select Case OpeType
    Case -1                     '初期化。使うのは最初のみ。
        Rec(n).Water(0) = 0
        Rec(n).Water(1) = 0
        ChangeFlag = True
    Case 0  '満タンにする
        If Rec(n - 1).Water(TgtAB) < Capa(TgtAB) Then   '既に満タンならこれ以上深くいかない
            Rec(n).Water(TgtAB) = Capa(TgtAB)
            Rec(n).Water(1 - TgtAB) = Rec(n - 1).Water(1 - TgtAB)
            ChangeFlag = True
        End If
    Case 1  '空にする
        If Rec(n - 1).Water(TgtAB) > 0 Then             '既に空ならこれ以上深くいかない
            Rec(n).Water(TgtAB) = 0
            Rec(n).Water(1 - TgtAB) = Rec(n - 1).Water(1 - TgtAB)
            ChangeFlag = True
        End If
    Case 2  '相手が満タンになるまで入れる
        If Rec(n - 1).Water(TgtAB) > 0 And Rec(n - 1).Water(1 - TgtAB) < Capa(1 - TgtAB) Then   '自分に移す水があり、相手に入れる余裕があること
            Rec(n).Water(TgtAB) = WorksheetFunction.Max(0, Rec(n - 1).Water(TgtAB) - (Capa(1 - TgtAB) - Rec(n - 1).Water(1 - TgtAB)))
            Rec(n).Water(1 - TgtAB) = WorksheetFunction.Min(Rec(n - 1).Water(1 - TgtAB) + Rec(n - 1).Water(TgtAB), Capa(1 - TgtAB))
            ChangeFlag = True
        End If
    End Select

    If ChangeFlag = True Then   '変化があったか？
        If Rec(n).Water(0) = tgtL Or Rec(n).Water(1) = tgtL Then    '4L達成で終了
            If NumOfMinRec > n Then '最小ルートの記録
                NumOfMinRec = n
                For i = 0 To n
                    MinRec(i) = Rec(i)
                Next
            End If
        Else
            If CheckPrevious(n, Rec(n).Water(0), Rec(n).Water(1)) = False Then  '過去に同じ状態があったか否かを確認
                For j = 0 To 1                  'バケツABの処理
                    For k = 0 To 2              '処理012の処理を全パターン実施
                        Call Operation(n + 1, k, j)
                    Next
                Next
            End If
        End If
    End If
End Sub

Private Function CheckPrevious(n As Integer, aW As Integer, bW As Integer) As Boolean
    '過去に同じ状態があったかどうかを確認する。あったらTrue、なかったらFalse
    Dim i As Integer
    CheckPrevious = False
    For i = 0 To n - 1
        If Rec(i).Water(0) = aW And Rec(i).Water(1) = bW Then
            CheckPrevious = True
            Exit For
        End If
    Next
End Function

'A容量=3L,B容量=5L
'1:A=0L, B=5L:Bを満タンにした。
'2:A=3L, B=2L:Bを相手に入れた。
'3:A=0L, B=2L:Aを空にした。
'4:A=2L, B=0L:Bを相手に入れた。
'5:A=2L, B=5L:Bを満タンにした。
'6:A=3L, B=4L:Bを相手に入れた。

Sub Makyuu2()

    ' 縦20(1-20) × 横10(A-J) のセル範囲限定
    Dim x As Long, y As Long, arr(21, 11) As Long, Asum As Long, ST_Asum As Long
    
    ' 配列のセル位置に該当する箇所全てに1をセット（初期化） ※更に一回り大きい部分は0になっている
    For y = 1 To 20
        For x = 1 To 10
            arr(y, x) = 1
        Next
    Next
      
    ' 上、右、下、左 それぞれで、罫線が無い隣り合う値に0があれば自身を0にする、前回との差が無ければループを抜ける
    Do
        ST_Asum = Asum
        Asum = 0
        For y = 1 To 20
            For x = 1 To 10
                If Cells(y, x).Borders(xlEdgeTop).LineStyle = -4142 And arr(y - 1, x) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeRight).LineStyle = -4142 And arr(y, x + 1) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeBottom).LineStyle = -4142 And arr(y + 1, x) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeLeft).LineStyle = -4142 And arr(y, x - 1) = 0 Then arr(y, x) = 0
                Asum = Asum + arr(y, x)
            Next
        Next
    Loop While Asum <> ST_Asum
    
    ' セル位置に該当する配列の値が1のとき色を塗る
    For y = 1 To 20
        For x = 1 To 10
            If arr(y, x) = 1 Then Cells(y, x).Interior.Color = vbYellow
        Next
    Next

End Sub

Sub VBA100本ノック_22_B()
    Cells.ClearContents
    Dim i As Long
    Dim clm As Long
    Dim talk As Variant
    Dim ans As Variant

    For i = 1 To 30
        Select Case True
            Case i Mod 15 = 0
                ans = "FizzBuzz": clm = 4
                Cells(i, clm) = IIf(talk = "", ans, talk)
            Case i Mod 5 = 0
                ans = "Buzz": clm = 3
                Cells(i, clm) = IIf(talk = "", ans, talk)
            Case i Mod 3 = 0
                ans = "Fizz": clm = 2
                Cells(i, clm) = IIf(talk = "", ans, talk)
            Case Else
                ans = i: clm = 1
                Cells(i, clm) = IIf(talk = "", ans, talk)
        End Select
        Cells(i, clm).Select
        If talk <> "" Then
            If talk <> ans Then
                Cells(i + 1, 1) = "はいダメーー"
                Exit Sub
            Else
                talk = ""
            End If
        End If
        If Int((10 - 1 + 1) * Rnd + 1) = 1 Then
           talk = RandRet(i + 1)
        End If
        Application.Wait [Now() + TimeValue("00:00:00.5")]
    Next
End Sub

Function RandRet(ByVal n As Long) As Variant
    Dim arr As Variant
    arr = Array(n, "Fizz", "Buzz", "FizzBuzz")
    RandRet = arr(WorksheetFunction.RandBetween(0, 3))
End Function

Option Explicit

Sub main()
    Cells.ClearContents
    
    Dim tryMin As Variant: tryMin = 1 '試行数値の最初の数値
    Dim tryTimes As Long: tryTimes = 1000 'tyrMinからいくつ計算したいか。
    
    Dim culcTimesCapa As Long: culcTimesCapa = 1000 '計算回数許容範囲
    
    Range("A1").Resize(tryTimes, culcTimesCapa + 2) = CollatzFullHorizontal(tryMin, tryTimes, culcTimesCapa)
                
End Sub

'計算過程：列方向へ出力
Function CollatzFullHorizontal( _
    ByVal tryMin As Variant, _
    ByVal tryTimes As Long, _
    Optional ByVal culcTimesCapa As Long) _
    As Variant
    
    If culcTimesCapa = 0 Then culcTimesCapa = 1000
    
    Dim tryMax As Variant: tryMax = tryMin + tryTimes - 1
    ReDim arr(tryTimes - 1, culcTimesCapa + 1) As Variant
    Dim i As Variant, j As Long
    Dim n As Variant, row As Long, col As Long
    
    
    For i = tryMin To tryMax
        n = i
        col = 1
        arr(row, col) = n
        Do While n <> 1
            If Right(n, 1) Mod 2 = 0 Then 'Rigth関数はオーバーフロー対策
                n = n / 2
            Else
                n = n * 3 + 1
            End If
            col = col + 1
            arr(row, col) = n
        Loop
        arr(row, 0) = col - 1 & "回"
        'このループはスピルで使用する場合はあった方が良い。スピルで使用しない場合はなくても良い
        For j = col + 1 To culcTimesCapa + 1
            arr(row, j) = ""
        Next
        '--------------------------------------------
        row = row + 1
    Next
    CollatzFullHorizontal = arr
End Function

Sub main()
    Cells.ClearContents
    
    Dim tryMin As Variant: tryMin = 1 '試行数値の最初の数値
    Dim tryTimes As Long: tryTimes = 1000 'tyrMinからいくつ計算したいか。※上限16384(Excelの最大列数)
    
    Dim culcTimesCapa As Long: culcTimesCapa = 1000 '計算回数許容範囲
    
    
    Range("A1").Resize(culcTimesCapa + 2, tryTimes) = CollatzFullVertical(tryMin, tryTimes, culcTimesCapa)
                
End Sub

'計算過程：行方向へ出力
Function CollatzFullVertical( _
    ByVal tryMin As Variant, _
    ByVal tryTimes As Long, _
    Optional ByVal culcTimesCapa As Long) _
    As Variant
    
    If culcTimesCapa = 0 Then culcTimesCapa = 1000
    
    Dim tryMax As Variant: tryMax = tryMin + tryTimes - 1
    ReDim arr(culcTimesCapa + 1, tryTimes - 1) As Variant
    Dim i As Variant, j As Long
    Dim n As Variant, row As Long, col As Long
    
    
    For i = tryMin To tryMax
        n = i
        row = 1
        arr(row, col) = n
        Do While n <> 1
            If Right(n, 1) Mod 2 = 0 Then 'Rigth関数はオーバーフロー対策
                n = n / 2
            Else
                n = n * 3 + 1
            End If
            row = row + 1
            arr(row, col) = n
        Loop
        arr(0, col) = row - 1 & "回"
        'このループはスピルで使用する場合はあった方が良い。スピルで使用しない場合はなくても良い
        For j = row + 1 To culcTimesCapa + 1
            arr(j, col) = ""
        Next
        '--------------------------------------------
        col = col + 1
    Next
    CollatzFullVertical = arr
End Function

Option Explicit

Sub main()
    Cells.ClearContents
    
    Dim tryMin As Variant: tryMin = 1 '試行数値の最初の数値
    Dim tryTimes As Long: tryTimes = 1000 'tyrMinから何番目まで計算したいか。※上限16384(Excelの最大列数)
    
    Dim culcTimesCapa As Long: culcTimesCapa = 1000 '計算回数許容範囲
    
    
    Range("A1").Resize(culcTimesCapa + 2, tryTimes) = CollatzFullVertical(tryMin, tryTimes, culcTimesCapa)
                
End Sub

'計算過程：行方向へ出力
Function CollatzFullVertical( _
    ByVal tryMin As Variant, _
    ByVal tryTimes As Long, _
    Optional ByVal culcTimesCapa As Long) _
    As Variant
    
    If culcTimesCapa = 0 Then culcTimesCapa = 1000
    
    Dim tryMax As Variant: tryMax = tryMin + tryTimes - 1
    ReDim arr(culcTimesCapa + 1, tryTimes - 1) As Variant
    Dim i As Variant, j As Long
    Dim n As Variant, row As Long, col As Long
    
    
    For i = tryMin To tryMax
        n = i
        row = 1
        arr(row, col) = n
        Do While n <> 1
            If Right(n, 1) Mod 2 = 0 Then 'Rigth関数はオーバーフロー対策
                n = n / 2
            Else
                n = n * 3 + 1
            End If
            row = row + 1
            arr(row, col) = n
        Loop
        arr(0, col) = row - 1 & "回"
        'このループはスピルで使用する場合はあった方が良い。スピルで使用しない場合はなくても良い
        For j = row + 1 To culcTimesCapa + 1
            arr(j, col) = ""
        Next
        '--------------------------------------------
        col = col + 1
    Next
    CollatzFullVertical = arr
End Function