えでゅっけ > とっても Excel > excel 100マス計算 VBAマクロ

100マス計算 VBAマクロ

説明

印刷イメージ外観 各種設定ができます。 イメージ外観(解答画面)
イメージ外観 各種設定ダイアログ
足し算・掛け算や、値の範囲など 解答画面も


実行の仕方はツールからマクロの実行を選び "Hyakumasu"というのを実行してください。 各種設定をし生成ボタンを押すと作ります。その後ダイアログを閉じて、適当に編集してください。大きさは適当になおしてください。(私のところでは1枚で表示できるようにしてます)

初めてVBAを始めて、これは2日で作ったので、インタフェースや実行の仕方が変ですが許してください。また引き算やわり算はたいしたことしてませんが、左側が被で上が加なので式で表すと(左側ー上側)となります。昔の98のころのBASICを少し思い出した感じがします。


ソース

マクロダウンロード

ソース
Private Const MIN_ADJUST = 15000 ' As Integer
'Private Const ARITH_SIGN = "X+-/"
Private Const ARITH_SIGN = "×+ー÷"

Dim offSetX As Integer, offSetY As Integer
Dim valueType As Integer, CalculateType As Integer, first100Masu As Integer
Dim maxValue As Integer, maxValuePlace  As Integer
'Dim OffsetAddress As String




Private Sub set100Masu()

    'MsgBox ("set!")
    'Worksheets.Item(3).Activate
    Call checkDefaultValue

    If first100Masu = 0 Then
        Worksheets.Item(1).Range("A1:Z30").Clear
        Worksheets.Item(2).Range("A1:Z30").Clear
    End If

'--------------------------------------

'init array
    Dim xa(10) As Integer, ya(10) As Integer
    Dim num As Integer, min As Integer, maxM As Integer
    Dim num2 As Integer, userMin As Integer

    min = 0
    minM = -32000
    userMin = 0
    If doSetMinValueCheckBox.Value Then
      userMin = MinValueBar.Value - MIN_ADJUST
    End If

    '除
    If CalculateType = 3 Then
        min = 1
    End If

    If valueType = 2 Or valueType = 1 Then

        If valueType = 2 Then
            num = 10 ^ maxValuePlace
        Else
            num = maxValue
        End If

        num = num - userMin


        If CalculateType = 3 Then
          For i = 0 To 9
             ya(i) = Int(Rnd() * num) + 1 + userMin
             xa(i) = Int(Rnd() * num) + userMin ' * ya(i)
          Next i
        ElseIf CalculateType = 2 And doPlusOnlyRadio.Value Then
            '引
            num2 = num * 2 / 3
            For i = 0 To 9
             ya(i) = Int(Rnd() * num2) + userMin
                If ya(i) > maxM Then
                    maxM = ya(i)
                End If
            Next i
            For i = 0 To 9
             xa(i) = Int(Rnd() * (num - maxM)) + maxM + userMin
            Next i
        Else
            For i = 0 To 9
              xa(i) = Int(Rnd() * num) + userMin
              ya(i) = Int(Rnd() * num) + userMin
            Next i
        End If

    Else

        For i = 0 To 9
          xa(i) = i
          ya(i) = i + min
        Next i

        'change value random
        Dim temp, i1, i2 As Integer
        num = 30
        temp = 0

        'xa
        For i = 0 To num

            i1 = Int(Rnd() * 10)
            i2 = Int(Rnd() * 10)

            temp = xa(i1)
            xa(i1) = xa(i2)
            xa(i2) = temp

        Next i

        'ya
        For i = 0 To num

            i1 = Int(Rnd() * 10)
            i2 = Int(Rnd() * 10)

            temp = ya(i1)
            ya(i1) = ya(i2)
            ya(i2) = temp

        Next i

    End If


    Call printFrame(xa, ya, offSetX, offSetY)
    Call setAttrOfFrame(offSetX, offSetY, CalculateType)

End Sub

  Private Sub printFrame(xa, ya, offSetX As Integer, offSetY As Integer)
    With Worksheets.Item(1) '.Activate
    For i = 0 To 9
      .Cells(offSetX + i + 1, offSetY + 0).Value = xa(i)
      .Cells(offSetX + 0, offSetY + i + 1).Value = ya(i)
      'Range(OffsetAddress).Offset(i + 1, 0).Value = xa(i)
      'Range(OffsetAddress).Offset(0, i + 1).Value = ya(i)
    Next i
    End With

    'Worksheets.Item(2).Activate
    With Worksheets.Item(2)
       For i = 0 To 9

         .Cells(offSetX + i + 1, offSetY + 0).Value = xa(i)
         .Cells(offSetX + 0, offSetY + i + 1).Value = ya(i)

           For j = 0 To 9
             'k = Call calc(xa(i) , ya(j) , calculateType)

              If CalculateType = 0 Then
                k = xa(i) * ya(j)
               ElseIf CalculateType = 1 Then
                 k = xa(i) + ya(j)
               ElseIf CalculateType = 2 Then
                    k = xa(i) - ya(j)
               ElseIf CalculateType = 3 Then
                k = xa(i) / ya(j)
               End If
                .Cells(offSetX + 1 + i, offSetY + 1 + j).Value = k
           Next j
       Next i

    End With
    'Worksheets.Item(1).Activate
End Sub


Private Sub setAttrOfFrame(offSetX, offSetY, CalculateType As Integer)


'MsgBox ("set init")

    'first100Masu = 0
If first100Masu = 0 Then
    first100Masu = 1

    'Selection.Clear
    Worksheets.Item(1).Name = "100マス計算"

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

    With Cells(offSetX, offSetY)
        .Value = ctype
        .Font.Bold = True
        .Font.Size = 32
        .HorizontalAlignment = xlHAlignCenter
    End With

    With Worksheets.Item(2)
        '.Activate
        '.Range("A1:Z30").Clear
        'Selection.Clear
        .Name = "100マス計算(解答)"
        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("B1")

        .Value = "100マス計算"
        .Font.Bold = True
        .Font.Size = 32

    End With

    With Worksheets.Item(1)
        .Range("H1").Value = "日付"
        .Range("I1").Value = Date
        .Range("I1").ShrinkToFit = True
        .Range("J1").Value = Format(Weekday(Date), "(aaaa)")
        .Range("H1:J1").Font.Underline = True

        .Range("B2").Value = "(      回)"
        .Range("B2").Font.Underline = True

        .Range("D2").Value = "(時間:    "
        .Range("E2").Value = "    分     秒)"
        .Range("D2:E2").Font.Underline = True

        .Range("H2").Value = "(名前:    "
        .Range("I2").Value = "          )"
        .Range("H2:I2").Font.Underline = True


        .Cells(offSetX + 11, offSetY + 1).Value = "コメント(体調など):"
    End With

    'frame
    For i = 1 To 2

        'Worksheets.Item(i).Activate
        With Worksheets.Item(i)
            With .Range(.Cells(offSetX, offSetY), .Cells(offSetX + 10, offSetY + 10))
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
            .Font.Size = 24
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
            .ShrinkToFit = True
            End With


        .Range(.Cells(offSetX + 1, offSetY), .Cells(offSetX + 10, offSetY)).Interior.ColorIndex = 17
        .Range(.Cells(offSetX, offSetY + 1), .Cells(offSetX, offSetY + 10)).Interior.ColorIndex = 19


        With .Range(.Cells(offSetX, offSetY), .Cells(offSetX + 10, offSetY + 10))
         .ColumnWidth = 7
         .RowHeight = 42
        End With

        '.Cells(1, 1).Active

       End With

    Next i

End If

    'first100Masu = 1

    'PageSetup.PrintArea = "$A$1:$K$17"
    'Range("A1:K17").PrintOut(0,1,1,True,,False,,)

End Sub


Private Sub checkDefaultValue()


    'OffsetAddress = "A4"
    'x と y が 逆のところがある
    offSetX = 4
    offSetY = 1
    first100Masu = 0

    'かけ算 0   足し算 1(,引き算 2)
    CalculateType = 0

    '足し算の時の桁
    maxValuePlace = 2
    '掛け算の時の最大数
    maxValue = 10


    'from form
    CalculateType = CalcTypeList.ListIndex
    maxValue = CInt(TextBox1.Value)
    maxValuePlace = CInt(TextBox2.Value)

    valueType = 2
    If OptionButton1.Value Then
     valueType = 0
    ElseIf OptionButton2.Value Then
     valueType = 1
    End If


    'check valid
    If maxValuePlace < 1 Then
      maxValuePlace = 1
    ElseIf maxValuePlace > 4 Then
      maxValuePlace = 4
    End If

    If maxValue < 3 Then
      maxValue = 3
    ElseIf maxValue > 99999 Then
      maxValuePlace = 99999
    End If
End Sub

Private Function getMaxValue()
    Dim ret As Integer
    valueType = 2
    ret = 10
    If OptionButton2.Value Then
     valueType = 0
     ret = CInt(TextBox1.Value)
    ElseIf OptionButton3.Value Then
     valueType = 1
     ret = 0
     On Error Resume Next
     ret = 10 ^ CInt(TextBox2.Value)
    End If

    getMaxValue = ret

    'MsgBox (Str(ret))

End Function

Private Function getMinValue()
    Dim ret As Integer
    ret = 0
    If doSetMinValueCheckBox.Value Then
     ret = MinValueBar.Value - MIN_ADJUST
    ElseIf OptionButton3.Value Then
     ret = 0
    End If

    getMinValue = ret
End Function





Private Sub doSetMinValueCheckBox_Change()
    Call MinValueBar_Change
    MinValueBar.Enabled = doSetMinValueCheckBox.Value
End Sub



Private Sub MakeButton_Click()
  Call set100Masu
End Sub

Private Sub MakeButton_Enter()
 Call set100Masu
End Sub



Private Sub StopButton_Click()
  'Stop
  HyakuMasuUserForm.Hide
End Sub



Private Sub CalcTypeList_Change()
    If CalcTypeList.ListIndex = 2 Then
        doPlusOnlyRadio.Visible = True
    Else
        doPlusOnlyRadio.Visible = False
    End If
End Sub



Private Sub OptionButton1_Change()
 Dim flg As Boolean
 flg = Not OptionButton1.Value

 doSetMinValueCheckBox.Enabled = flg
 MinValueBar.Enabled = flg And doSetMinValueCheckBox.Value

End Sub

Private Sub OptionButton2_Change()
  TextBox1.Enabled = OptionButton2.Value
End Sub

Private Sub OptionButton3_Change()
    TextBox2.Enabled = OptionButton3.Value
    'TextBox2.Visible
End Sub

Private Sub MinValueBar_Change()
    Dim v As Integer, mx As Integer
    v = MinValueBar.Value - MIN_ADJUST
    mx = getMaxValue()
    If v >= mx Then
        MinValueBar.Value = mx - 1 + MIN_ADJUST
        v = mx - 1
    End If
   MinValueLabel.Caption = Str(v)
End Sub

Private Sub TextBox2_Change()
  Dim k As Integer
  k = 0
  On Error Resume Next
  k = CInt(TextBox2.Value)

  If k > 0 & k < 4 Then
    Label2.Caption = "1 - " & Str(10 ^ k)
  Else
    Label2.Caption = "Bad Number(1-3)"
  End If
End Sub

Private Sub UserForm_Initialize()
    CalcTypeList.Clear
    CalcTypeList.AddItem ("掛け算")
    CalcTypeList.AddItem ("足し算")
    CalcTypeList.AddItem ("引き算(適当)")
    CalcTypeList.AddItem ("割り算(できない)")

    CalcTypeList.ListIndex = 0

    Call TextBox2_Change
    Call OptionButton2_Change
    Call OptionButton3_Change
    Call CalcTypeList_Change
    Call doSetMinValueCheckBox_Change

End Sub

keywords
100マス 百ます 百升 計算 Excel 2000 VBA


えでゅっけ > とっても Excel > excel 100マス VBAマクロ