anonymous 相性占い
VBA
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
anonymous No title
VBA
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

しゃあ@やっぱりVBAが好き No title
VBA
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を相手に入れた。
anonymous 魔球2
VBA
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
anonymous No title
VBA
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
anonymous コラッツ予想 計算過程:列方向へ出力
VBA
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

anonymous コラッツ予想 計算過程:行方向へ出力
VBA
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

anonymous コラッツ予想 計算過程:行方向へ出力
VBA
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


anonymous No title
VBA
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


anonymous コラッツ予想 計算過程:列方向へ出力
VBA
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(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

Don't you submit code?
Submit