数学とExcel～問題自動作成ツールコード～
因数分解
Excelシートの設定
下記のようにExcelシートを設定します
シートは「設定」「問題」「解答」「リスト」を用意
（「リスト」はマクロの動作には影響せず、難易度の設定のために使用しています）
シートの内容を下記のようにします
「設定」にはマクロボタンを設置
難易度欄には、「リスト」の内容を、
作成する問題数には、リストで、5、10、15、20を入れています
（リストシートで管理してもいいです）
リストはExcelのデータタブからリストを作成してください
今回の難易度は「難易度1」と「難易度2」を設定しています
難易度1は中学生向け、難易度2は高校生向けです
コードの入力
モジュールを分けて下記を入力します
今回はコードにコメントを残していませんので、興味のある方は分析を頑張ってください
made_question
Sub made_question()
Dim wb As Workbook
Dim ws0 As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim diff As String
Dim num_q As Long
Set wb = ThisWorkbook
Set ws0 = wb.Sheets("設定")
Set ws1 = wb.Sheets("問題")
Set ws2 = wb.Sheets("解答")
diff = ws0.Range("C2").Value
num_q = ws0.Range("C3").Value
If diff = "" Then
MsgBox "難易度が空欄です"
Exit Sub
End If
If num_q = 0 Then
MsgBox "作成する問題数が空欄です"
Exit Sub
End If
If diff = "難易度1" Then
Call made_Q_diff1(ws1, ws2, num_q)
ElseIf diff = "難易度2" Then
Call made_Q_diff2(ws1, ws2, num_q)
End If
ws1.Activate
End Submade_Q_diff1
Sub made_Q_diff1(ws1 As Worksheet, ws2 As Worksheet, num_q As Long)
Application.ScreenUpdating = False
Dim i As Long, j As Long
Dim a0 As Long, a1 As String
Dim b0 As Long, b1 As String
Dim p0 As Long, p1 As String
Dim q0 As Long, q1 As String
Dim num(20) As Long
Dim rand As Long
Dim insu As String
Dim bunkai As String
For i = 0 To 20
num(i) = i - 10
Next i
For i = 0 To num_q - 1
rand = Int(21 * Rnd)
a0 = num(rand)
rand = Int(21 * Rnd)
b0 = num(rand)
p0 = (-1) * (a0 + b0)
q0 = a0 * b0
If a0 > 0 Then
a1 = "+" & a0
ElseIf a0 = 0 Then
a1 = ""
Else
a1 = a0
End If
If b0 > 0 Then
b1 = "+" & b0
ElseIf b0 = 0 Then
b1 = ""
Else
b1 = b0
End If
If p0 = 1 Then
p1 = "+x"
ElseIf p0 = -1 Then
p1 = "-x"
ElseIf p0 > 0 Then
p1 = "+" & p0 & "x"
ElseIf p0 = 0 Then
p1 = ""
Else
p1 = p0 & "x"
End If
If q0 > 0 Then
q1 = "+" & q0
ElseIf q0 = 0 Then
q1 = ""
Else
q1 = q0
End If
If a0 = b0 And a0 <> 0 Then
insu = "(x" & a1 & ")^2"
ElseIf a0 = 0 Then
insu = "x(x" & b1 & ")"
ElseIf b0 = 0 Then
insu = "x(x" & a1 & ")"
Else
insu = "(x" & a1 & ")(x" & b1 & ")"
End If
bunkai = "x^2" & p1 & q1
ws1.Cells(i + 2, 2).Value = i + 1
ws1.Cells(i + 2, 3).Value = bunkai
ws2.Cells(i + 2, 2).Value = i + 1
ws2.Cells(i + 2, 3).Value = insu
If a0 = 0 And b0 = 0 Then
i = i - 1
End If
Next i
Application.ScreenUpdating = True
End SubSub made_Q_diff2
Sub made_Q_diff2(ws1 As Worksheet, ws2 As Worksheet, num_q As Long)
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long
Dim a0(1) As Long, a1(1) As String
Dim b0(1) As Long, b1(1) As String
Dim p0 As Long, p1 As String
Dim q0 As Long, q1 As String
Dim r0 As Long, r1 As String
Dim num0(4) As Long, num1(20) As Long
Dim random As Long, rand As Long
Dim insu As String, bunkai As String
Dim keisu As Long
For i = 0 To 4
num0(i) = i + 1
Next i
For i = 0 To 20
num1(i) = i - 10
Next i
For i = 0 To num_q - 1
keisu = 1
For j = 0 To 1
rand = Int(5 * Rnd)
a0(j) = num0(rand)
Next j
For j = 0 To 1
rand = Int(21 * Rnd)
b0(j) = num1(rand)
Next j
For j = 0 To 1
For k = 5 To 2 Step -1
If a0(j) Mod k = 0 And b0(j) Mod k = 0 Then
keisu = keisu * k
a0(j) = a0(j) / k
b0(j) = b0(j) / k
If a0(j) = 1 Then
a1(j) = "x"
Else
a1(j) = a0(j) & "x"
End If
If b0(j) > 0 Then
b1(j) = "+" & b0(j)
ElseIf b0(j) = 0 Then
b1(j) = ""
Else
b1(j) = b0(j)
End If
Else
a0(j) = a0(j)
b0(j) = b0(j)
If a0(j) = 1 Then
a1(j) = "x"
Else
a1(j) = a0(j) & "x"
End If
If b0(j) > 0 Then
b1(j) = "+" & b0(j)
ElseIf b0(j) = 0 Then
b1(j) = ""
Else
b1(j) = b0(j)
End If
End If
Next k
Next j
p0 = a0(0) * a0(1) * keisu
q0 = keisu * (a0(0) * b0(1) + a0(1) * b0(0))
r0 = keisu * b0(0) * b0(1)
If p0 = 1 Then
p1 = "x^2"
Else
p1 = p0 & "x^2"
End If
If q0 = 1 Then
q1 = "+x"
ElseIf q0 = -1 Then
q1 = "-x"
ElseIf q0 > 0 Then
q1 = "+" & q0 & "x"
ElseIf q0 = 0 Then
q1 = ""
ElseIf q0 < 0 Then
q1 = q0 & "x"
End If
If r0 > 0 Then
r1 = "+" & r0
ElseIf r0 = 0 Then
r1 = ""
Else
r1 = r0
End If
If a0(0) = a0(1) And b0(0) = b0(1) And b0(0) <> 0 Then
If keisu = 1 Then
insu = "(" & a1(0) & b1(0) & ")^2"
Else
insu = keisu & "(" & a1(0) & b1(0) & ")^2"
End If
ElseIf b0(0) = 0 And b0(1) <> 0 Then
If keisu = 1 Then
insu = a1(0) & "(" & a1(1) & b1(1) & ")"
Else
insu = keisu * a1(0) & "(" & a1(1) & b1(1) & ")"
End If
ElseIf b0(0) <> 0 And b0(1) = 0 Then
If keisu = 1 Then
insu = a1(1) & "(" & a1(0) & b1(0) & ")"
Else
insu = keisu * a1(1) & "(" & a1(0) & b1(0) & ")"
End If
Else
If keisu = 1 Then
insu = "(" & a1(0) & b1(0) & ")(" & a1(1) & b1(1) & ")"
Else
insu = keisu & "(" & a1(0) & b1(0) & ")(" & a1(1) & b1(1) & ")"
End If
End If
bunkai = p1 & q1 & r1
ws1.Cells(i + 2, 2).Value = i + 1
ws1.Cells(i + 2, 3).Value = bunkai
ws2.Cells(i + 2, 2).Value = i + 1
ws2.Cells(i + 2, 3).Value = insu
If q0 = 0 And r0 = 0 Then
i = i - 1
End If
Next i
ws1.Activate
Application.ScreenUpdating = True
End Subリセット
Sub リセット()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("問題")
Set ws2 = wb.Sheets("解答")
ws1.Cells.ClearContents
ws2.Cells.ClearContents
End Sub
マクロボタンに、モジュール「made_question」と「リセット」をそれぞれ登録してください
モジュール「made_question」を実行すると、下記のようになります
問題番号も自動的に入ります
