サイトスワップ掲示板

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

No.106: 2018-10-08(月) 06:53:47
投稿者: セバスちゃん
まずブックに張り付ける分
Sub joutai()
Dim sisp(20) As Long
Dim jouko(20) As String
Dim joumoji(20) As String
Dim ikisaki(20) As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim e As Long
Dim f As Long
Dim i As Long
Dim keikoku As Long
Dim nagasa As Long
Dim kosuu As Long
Dim kosuuherasi As Long
Dim jouta As String
For a = 1 To 20
ikisaki(a) = 0
Next a
kosuu = 0
Range("a9:s28").Interior.Color = RGB(255, 255, 255)
Range("a2:s8").Value = ""
With ActiveSheet
For i = .Shapes.count To 1 Step -1
If .Shapes(i).Type = msoLine Then .Shapes(i).Delete
Next i
End With
For a = 1 To 20
If Cells(1, a).Value <> "" Then
sisp(a) = Cells(1, a).Value
kosuu = kosuu + sisp(a)
nagasa = a
Else
kosuu = kosuu / nagasa
Cells(7, 1).Value = kosuu
Exit For
End If
Next a
' Cells(10, 1).Value = kosuu
For a = 1 To nagasa
Cells(2, a).Value = sisp(a) + a
f = 0
Do While Cells(2, a).Value > nagasa
Cells(2, a).Value = Cells(2, a).Value - nagasa
f = f + 1
If f = 1000 Then
Cells(5, 5).Value = 1
Exit Do
End If
Loop
If ikisaki(Cells(2, a).Value) = 0 Then
ikisaki(Cells(2, a).Value) = 1
Else
keikoku = 1
End If
Next a
If keikoku = 1 Then
MsgBox ("行き先がかぶっているのでジャグリング不可能です")
Exit Sub
End If
For a = 1 To nagasa
kosuuherasi = kosuu
jouta = ""
b = a
c = 0
For e = 1 To 20
jouko(e) = "1"
Next e
f = 0
Do While kosuuherasi > 1
b = b - 1
c = c + 1
If b = 0 Then
b = nagasa
End If
If Cells(1, b).Value - c > 0 Then
jouko(Cells(1, b).Value - c) = "0"
kosuuherasi = kosuuherasi - 1
End If
f = f + 1
If f = 1000 Then
Cells(5, 5).Value = 2
Exit Do
End If
Loop
d = 0
e = 1
f = 0
Do While d < kosuu - 1
If jouko(e) = "0" Then
d = d + 1
End If
jouta = jouko(e) + jouta
e = e + 1
f = f + 1
If f = 1000 Then
Cells(5, 5).Value = 3
Exit Do
End If
Loop
jouta = "1" + jouta
Cells(3, a).Value = jouta
e = 0
For d = 1 To 20
If jouko(d) = "1" Then
Cells(4, a).Value = Cells(4, a).Value + Str(d) + ","
Cells(d + 9, a).Interior.Color = RGB(216, 216, 216)
Else
e = e + 1
End If
If e = kosuu - 1 Then
Cells(4, a).Value = Cells(4, a).Value + Str(d + 1) + "以上"
For i = d To 18
Cells(i + 10, a).Interior.Color = RGB(216, 216, 216)
Next i
Cells(Cells(1, a).Value + 9, a).Interior.Color = RGB(255, 0, 0)
Exit For
End If
Next d

Next a
For a = 1 To nagasa
If Cells(1, a).Value = 0 Then
Cells(3, a).Value = ""
Cells(4, a).Value = ""
End If

Next a
For a = 1 To nagasa
If Cells(1, a).Value > 0 Then

With ActiveSheet.Shapes.AddLine(Cells(Cells(1, a).Value + 9, a + 1).Left, Cells(Cells(1, a).Value + 9, a).Top, Cells(9, Cells(1, a).Value + a).Left, Cells(9, Cells(1, a).Value + a - 1).Top).Line
.ForeColor.RGB = vbRed
.Weight = 2
End With
ActiveSheet.Shapes.AddLine Cells(9, a).Left, Cells(9, a).Top, Cells(Cells(1, a).Value + 9, a + 1).Left, Cells(Cells(1, a).Value + 9, a + 1).Top

End If
Next a
End Sub

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

No.107: 2018-10-08(月) 06:59:57
投稿者: セバスちゃん
Sheet1用

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim a As Long
Dim b As Long
Dim gyou As Long
Dim retu As Long
Dim motoss As Long
Dim motoiki As Long
Dim taisiss As Long
Dim taisiiki As Long
Dim kosuu As Long
Dim nagasa As Long
Dim sisp(100) As Long
Dim sssa As Long
Dim saigoss As Long
Const ss0 As Long = 9
Const sslast As Long = 28

gyou = Target.Row
retu = Target.Column
For a = 1 To 20
If Cells(1, a).Value <> "" Then
sisp(a) = Cells(1, a).Value
kosuu = kosuu + sisp(a)
nagasa = a
Else
kosuu = kosuu / nagasa
Exit For
End If
Next a
If gyou > ss0 And gyou <= sslast Then
motoss = Cells(1, retu).Value
motoiki = Cells(2, retu).Value
taisiss = Cells(gyou, retu).Value
taisiiki = taisiss - motoss + motoiki
If motoiki = taisiiki Then
MsgBox "かわらない"
Exit Sub
End If
b = 0
Do While b = 0
If taisiiki < 1 Then
taisiiki = taisiiki + nagasa
ElseIf taisiiki > nagasa Then
taisiiki = taisiiki - nagasa
Else
b = 1
End If
Loop
If motoiki = taisiiki Then
MsgBox "個数が変わってしまいます"
Exit Sub
End If
sssa = taisiss - motoss
For a = 1 To nagasa
If Cells(2, a).Value = taisiiki Then
saigoss = Cells(1, a).Value - (sssa)
If saigoss < 0 Then
MsgBox "-値になります"
Exit Sub
End If
Cells(1, a).Value = saigoss
End If
Next a
Cells(1, retu).Value = taisiss
joutai
End If
End Sub

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

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

No.109: 2018-10-08(月) 07:10:46
投稿者: セバスちゃん
画像は貼り付けられないのかな
Sheet1のA8行目からA28行目まで0,1,2…19と入力
同じようにK行までコピペ

1行めにサイトスワップを1文字ずつ入力。
最初のマクロを実行すると先ほどの範囲内にノーテーションが
表示される。
範囲内の数字をダブルクリックすると、サイトスワップが編集できる。

Sheet2を開くとそのサイトスワップが簡易シミュレートされる。
以上です。

掲示板に戻る