サイトスワップ掲示板

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

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

関連ツリー

【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

掲示板に戻る