えでゅっけ > とっても Excel > excel 計算ドリル VBAマクロ

計算ドリル VBAマクロ

説明

印刷イメージ外観 2桁の外観 複数で
問題数や掛け算、負数や数値の範囲などを変えられます。

答えは今のところ表示しません。

実行の仕方はAlt-F11から VBEditorを開き フォームをクリックしてから 再生ボタン(右向き三角)を押して、 実行してください。


ソース

マクロダウンロード

ソース

Dim maxValue As Integer, minValue As Integer
Dim xmax As Integer, ymax As Integer
Dim startX As Integer, startY As Integer
'Dim maxValue As Integer, minValue As Integer
Dim operandIndex As Integer

Dim operands(5) As Variant

Const printWidth = 70
Const printHeight = 600

Private Sub changeOwnOptionButton_Change()
    Call changeOwnOptionButton_Click
End Sub

Private Sub changeOwnOptionButton_Click()
    maxLabel.Caption = Str(maxScrollBar.Value)
    minLabel.Caption = Str(minScrollBar.Value)

    minScrollBar.Enabled = changeOwnOptionButton.Value
    maxScrollBar.Enabled = changeOwnOptionButton.Value
    minScrollBar.Visible = changeOwnOptionButton.Value
    maxScrollBar.Visible = changeOwnOptionButton.Value
End Sub

Private Sub doNegativeCheckBox_Click()
    If doNegativeCheckBox.Value Then
        minLabel.Caption = "-" & maxLabel.Caption
    ElseIf changeOwnOptionButton.Value Then
        minLabel.Caption = Str(minScrollBar.Value)

    Else
        minLabel.Caption = "0"
    End If
End Sub

Private Sub MakeButton_Click()
    Call makeStart
End Sub

Private Sub maxScrollBar_Change()
    If maxScrollBar.Value < 0 And Not (doNegativeCheckBox.Value) Then
        maxScrollBar.Value = 0
    End If
    If maxScrollBar.Value < getMinValue Then
        minScrollBar.Value = maxScrollBar.Value
        minLabel.Caption = Str(minScrollBar.Value)
    End If

    maxLabel.Caption = Str(maxScrollBar.Value)
End Sub

Private Sub minScrollBar_Change()
    If minScrollBar.Value < 0 And Not (doNegativeCheckBox.Value) Then
        minScrollBar.Value = 0
    End If

    If minScrollBar.Value > getMaxValue Then
        maxScrollBar.Value = minScrollBar.Value
        maxLabel.Caption = Str(maxScrollBar.Value)
    End If

    minLabel.Caption = Str(minScrollBar.Value)
End Sub

Private Sub onePlaceOptionButton_Click()
    maxLabel.Caption = Str(9)

    minLabel.Caption = Str(0)
    Call doNegativeCheckBox_Click
End Sub

Private Sub operandListBox_Click()
    rangeLabel.Caption = "<-(" & operandListBox.Value & ")->"
    If operandListBox.ListIndex = 3 Then
        doIntegerCheckBox.Visible = True
    Else
        doIntegerCheckBox.Visible = False
    End If
End Sub

Private Sub StopButton_Click()
    CalcDoriru.Hide
End Sub

Private Sub TwoPlaceOptionButton_Click()
    maxLabel.Caption = Str(99)
    minLabel.Caption = Str(0)
    Call doNegativeCheckBox_Click
End Sub

Private Sub UserForm_Initialize()

    Dim a As Variant

    startX = 1
    startY = 4
    xmax = 2
    ymax = 20

    a = Array(1, 2, 3, 4, 5, 6)

    With xNumComboBox
        For i = 0 To 5
            .AddItem (Str(a(i)))
        Next i
        .ListIndex = 1
    End With


    a = Array(5, 10, 15, 20, 25, 30, 40, 50, 60, 80, 100)
    With yNumComboBox
        For i = 0 To 10
            .AddItem (Str(a(i)))
        Next i
        .ListIndex = 4
    End With

    operands(0) = "+"
    operands(1) = "ー"
    operands(2) = "×"
    operands(3) = "÷"
    operands(4) = "@"

    With operandListBox
        .AddItem ("+")
        .AddItem ("ー")
        .AddItem ("×")
        .AddItem ("÷")
        '.AddItem ("*")
        '.AddItem ("/")
        .AddItem ("Random")
        .ListIndex = 0
    End With

    onePlaceOptionButton.Value = True
    TwoPlaceOptionButton.Value = False
    changeOwnOptionButton.Value = False


    Call changeOwnOptionButton_Click
    Call onePlaceOptionButton_Click

End Sub



Private Sub makeStart()

    Call init
    Call setProblem
    Call setAttr
    Call printHeader
    'Call printFooter

End Sub

Private Sub init()
    Call setParameters

    'If doRefleshScreenCheckBox.Value Then
        'Range("A1:Z30").ClearContents
        Range("A1:CZ100").Clear
    'End If

End Sub

Private Sub setParameters()

    Dim t As Integer



    On Error Resume Next
    t = xmax
    t = CInt(xNumComboBox.Value)
    xmax = t

    t = ymax
    t = CInt(yNumComboBox.Value)
    ymax = t

    operandIndex = operandListBox.ListIndex
    'MsgBox (Str(operandIndex))
    'operand = operandListBox.Value
    If operandIndex > 3 Or operandIndex < 0 Then
        'operand = ""
        operandIndex = 4
    End If

    maxValue = 10
    maxValue = getMaxValue

    minValue = 0
    minValue = getMinValue

End Sub

Private Sub setProblem()
    Dim i As Integer, j As Integer, v As Integer, oi As Integer
    Dim flg As Boolean, flg_i As Boolean
    Dim tv As Integer

    flg_po = Not (doNegativeCheckBox.Value)
    flg_i = doIntegerCheckBox.Value
    oi = operandIndex

    'MsgBox (Str(operandIndex))

    For i = 0 To xmax - 1
        For j = 0 To ymax - 1
            v1 = Int(Rnd() * (maxValue - minValue)) + minValue
            v2 = Int(Rnd() * (maxValue - minValue)) + minValue
            v = j + 1 + i * ymax
            If operandIndex > 3 Then
                oi = Int(Rnd() * 4)
            End If

            If oi = 1 And flg_po Then
                v1 = v1 + v2
            ElseIf oi = 3 Then
                If flg_i Then
                    v1 = v1 * v2
                ElseIf flg_po And v1 < v2 Then
                    tv = v1
                    v1 = v2
                    v2 = tv
                End If
                If v2 = 0 Then
                    v2 = 0
                End If
            End If

            Cells(j + startY, i + startX).Value = Format(v, "(###)") _
                & Str(v1) & " " & operands(oi) _
                & " " & Str(v2) & " =   "
                '& Format(v2, " #### =    ")
            'Cells(i + startX, j + startY).Value = Str(i) & " " & Str(j)
                '"(" & Str(v) & "). "
        Next j
    Next i

End Sub

Private Sub setAttr()
    Dim xt As Integer
    xt = xmax
    'If xt < 2 Then
    '    xt = 2
    'End If
    With Range(Cells(startY, startX), _
            Cells(startY + ymax - 1, startX + xt - 1))
        .ColumnWidth = Int(printWidth / xt)
        .RowHeight = Int(printHeight / ymax)
        '.Borders.LineStyle = xlContinuous
        '.Font.Bold = True
        .Font.Size = Int(.RowHeight * 8 / 10)
        If LeftAlignCheckBox.Value Then
            .HorizontalAlignment = xlHAlignLeft
        Else
            .HorizontalAlignment = xlHAlignCenter
        End If
            .VerticalAlignment = xlVAlignCenter

        .ShrinkToFit = True
    End With

    Cells(1, 1).Activate
End Sub


Private Sub printHeader()

    Worksheets.Item(1).Name = "計算ドリル"

    'ctype = Mid(ARITH_SIGN, CalculateType + 1, 1)

'    With Worksheets.Item(2)
'        '.Activate
'        '.Range("A1:Z30").Clear
'        'Selection.Clear
'        .Name = "計算ドリル(解答)"
'        With .Range("B1")
'            .Value = "100マス計算(解答)"
'            .Font.Bold = True
'            .Font.Italic = True
'        End With
'         With .Cells(OffsetX, OffsetY)
'            .Value = ctype
'            .Font.Bold = True
'            .Font.Size = 32
'            .HorizontalAlignment = xlHAlignCenter
'            .VerticalAlignment = xlVAlignCenter
'        End With
'     End With

    With Range("A1")
        .Value = "計算ドリル"
        .Font.Bold = True
        .Font.Size = 20
    End With

    With Worksheets.Item(1)
        If xmax < 2 Then
            .Range("A2").Value = "日付" & Date & Format(Weekday(Date), "(aaaa)") _
            & "(時間:     分     秒)"
            .Range("A3").Value = "(      回)  (名前:                   )"
        Else
            .Range("A2").Value = "日付" & Date & Format(Weekday(Date), "(aaaa)")
            .Range("B2").Value = "(時間:     分     秒)"
            .Range("A3").Value = "(      回)"
            .Range("B3").Value = "(名前:                   )"
            .Range("B2:B3").Font.Underline = True
        End If

        .Range("A2").ShrinkToFit = True
        .Range("A2:A3").Font.Underline = True
        '.Cells(OffsetX + 11, OffsetY + 1).Value = "コメント(体調など):"
    End With

End Sub


Private Function getMaxValue()

    If onePlaceOptionButton.Value Then
        getMaxValue = 9 + 1
    ElseIf TwoPlaceOptionButton.Value Then
        getMaxValue = 99 + 1
    Else
        Dim t As Integer
        t = 10
        On Error Resume Next
        t = CInt(maxScrollBar.Value)
        getMaxValue = t
    End If

End Function


Private Function getMinValue()

    If doNegativeCheckBox.Value Then
        getMinValue = 1 - getMaxValue
    ElseIf onePlaceOptionButton.Value Then
        getMinValue = 0
    ElseIf TwoPlaceOptionButton.Value Then
        getMinValue = 0
    Else
        Dim t As Integer
        t = 10
        On Error Resume Next
        t = CInt(minScrollBar.Value) ' - MIN_VALUE
        getMinValue = t
    End If

End Function




えでゅっけ > とっても Excel > excel 計算ドリル VBAマクロ