サイトスワップ掲示板

Re^2: エクセルマクロによるジャグリングエディター及び簡易シミュレーター

No.108: 2018-10-08(月) 07:02:00
投稿者: セバスちゃん
Sheet2用

Private Sub Worksheet_Activate()
Dim a As Long
Dim ballx(100) As Long
Dim bally(100) As Long
Dim ballxb(100) As Long
Dim ballyb(100) As Long
Dim ballybb(100) As Long
Dim ballxbb(100) As Long
Dim balls(100) As Long
Dim ballscount(100) As Long
Dim b As Long
Dim c As Long
Dim nagasa As Long
Dim count As Long
Dim cosu As Long
Dim d As Long
Dim kasoku As Double
Const saidaikosuu As Long = 20
count = 1
kasoku = Cells(3, 21).Value
cosu = Worksheets(1).Cells(7, 1).Value
For a = 1 To saidaikosuu
balls(a) = 0
bally(a) = 2
ballyb(a) = 2
ballxb(a) = 1
ballxbb(a) = 1
ballybb(a) = 2
Next a
For a = 1 To 20
Cells(1, a).Value = Worksheets(1).Cells(1, a).Value
If Cells(1, a).Value = "" Then
nagasa = a - 1
Cells(1, 24).Value = nagasa
Exit For
End If
Next a
Range("a1:t500").Interior.Color = RGB(255, 255, 255)
b = 1
For a = 1 To Cells(1, 21).Value

For c = 1 To Cells(2, 21).Value
Next c
Cells(1, 23).Value = a
If b = 1 Then
For d = 1 To cosu
If ballscount(d) < 8 Then
Exit For
End If
Next d
balls(d) = Cells(1, count).Value
Range("a1:t1").Interior.Color = RGB(255, 255, 255)
Cells(1, count).Interior.Color = RGB(255, 0, 0)
ballscount(d) = balls(d) * 10
count = count + 1
Cells(2, 23).Value = count
If count = nagasa + 1 Then
count = 1
End If
End If
Cells(3, 23).Value = b
b = b + 1
If b = 11 Then
b = 1
End If

For c = 1 To cosu
If balls(c) > 0 Then
If ballx(c) > 0 Then
ballxbb(c) = ballxb(c)
ballxb(c) = ballx(c)

End If
ballybb(c) = ballyb(c)
ballyb(c) = bally(c)
If ballscount(c) > 8 Then
ballx(c) = Int(20 / (balls(c) * 10 - 8) * (balls(c) * 10 + 1 - ballscount(c)))
bally(c) = Int((kasoku) * ((balls(c) * 10 - 8) / 2) * ((balls(c) * 10 + 1) - ballscount(c)) - (0.5 * kasoku * ((balls(c) * 10 + 1) - ballscount(c)) ^ 2))
If bally(c) <= 1 Then
bally(c) = 2
End If
ElseIf ballscount(c) > 0 Then
ballx(c) = Int(20 / 8 * ballscount(c))
bally(c) = 2
End If
Cells(2, c).Value = ballx(c)
Cells(3, c).Value = bally(c)
If ballx(c) < 1 Then
ballx(c) = 1
End If
Cells(bally(c), ballx(c)).Interior.Color = RGB(0, 0, 0)
'Cells(bally(c) + 1, ballx(c)).Interior.Color = RGB(0, 0, 0)

If ballxb(c) <> ballx(c) Or ballyb(c) <> bally(c) Then
Select Case Cells(4, 21).Value
Case 1
Cells(ballyb(c), ballxb(c)).Interior.Color = RGB(205, 205, 205)
Case Else
Cells(ballyb(c), ballxb(c)).Interior.Color = RGB(255, 255, 255)
End Select
'Cells(ballyb(c) + 1, ballxb(c)).Interior.Color = RGB(255, 255, 255)

End If
' If ballxbb(c) <> ballxb(c) Or ballybb(c) <> ballyb(c) Then
' Cells(ballybb(c), ballxbb(c)).Interior.Color = RGB(255, 255, 255)
'Cells(ballyb(c) + 1, ballxb(c)).Interior.Color = RGB(255, 255, 255)

'End If
End If
ballscount(c) = ballscount(c) - 1
Next c
Next a

End Sub

関連ツリー

【1】 エクセルマクロによるジャグリングエディター及び簡易シミュレーター No.106 セバスちゃん 2018-10-08(月) 06:53:47
Re: エクセルマクロによるジャグリングエディター及び簡易シミュレーター No.107 セバスちゃん 2018-10-08(月) 06:59:57
Re^2: エクセルマクロによるジャグリングエディター及び簡易シミュレーター No.108 セバスちゃん 2018-10-08(月) 07:02:00
Re^3: エクセルマクロによるジャグリングエディター及び簡易シミュレーター No.109 セバスちゃん 2018-10-08(月) 07:10:46

掲示板に戻る