サイトスワップ掲示板

仕事中でも使えるサイトスワップ作成用エクセルマクロ

No.75: 2015-10-13(火) 00:01:04
投稿者: セバスちゃん
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim gyou As Long 'ダブルクリックしたセルの行番号を格納する
Dim retu As Long 'ダブルクリックしたセルの列番号を格納する。
Dim a As Long '
Dim nagasa As Long 'サイトスワップの長さ
Dim k As Long '
Dim ss As Long 'ダブルクリックした行と同じ列を下って最初の1が現れたかどうかの判定用
Dim i As Long '
Dim j As Long '
Dim ball_aru As Long 'ある行に1があるかどうかの判定用
Dim sss As Variant '
sss = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z")

gyou = Target.Row 'ダブルクリックしたセルの行番号を格納
retu = Target.Column 'ダブルクリックしたセルの列番号を格納
For i = 1 To 10000 '
If Cells(i, 1).Value <> "" Then
nagasa = i
End If
If nagasa < gyou Then
nagasa = gyou
End If
Next i
If gyou < 37 Then
Cells(gyou, retu).Value = 1 'ダブルクリックしたセルに1を書き込む
End If
For a = 1 To 36 'ダブルクリックした行の残りのセルに0を書き込む
If retu <> a Then
Cells(gyou, a).Value = 0
End If
Next af

For i = 1 To nagasa '37列目にサイトスワップを書き込むための処理
ball_aru = 0
For j = 1 To 36 '1列から36列までボールが存在する列についてそのボールのサイトスワップを調べていく
If Cells(i, j).Value = 1 Then 'ある列に1があった時、その列を長さ分検索して最初に1が現れるまでの長さをサイトスワップに変換して37列目に書き込む
ball_aru = 1
ss = 0
For k = i + 1 To nagasa '今判定中の行から最終行まで
If Cells(k, j).Value = 1 And ss = 0 Then
ss = 1
Cells(i, 37).Value = sss(k - i)
End If
Next k
For k = 1 To i '最初の行から今判定中の行まで
If Cells(k, j).Value = 1 And ss = 0 Then
ss = 1
Cells(i, 37).Value = sss(nagasa - i + k)
End If
Next k
End If
Next j
If ball_aru = 0 Then '判定中の行に1がなければ37列目にサイトスワップ「0」を書き込む
Cells(i, 37).Value = sss(0)
End If

Next i
Cells(1, 38).Value = "" '38列目の先頭行にサイトスワップ列を書き込む
For i = 1 To nagasa
Cells(1, 38).Value = Cells(1, 38).Value & Cells(i, 37).Value
Next i

End Sub

Re: 仕事中でも使えるサイトスワップ作成用エクセルマクロ

No.76: 2015-10-13(火) 00:03:30
投稿者: セバスちゃん
このエクセルマクロの使い方。
このマクロはワークシートに埋め込むタイプのマクロです。
まず、ブックを新規作成します。
適当な名前を付けて、「マクロ有効ブック」で保存します。
エクセルのリボンに、「開発」タブが表示されているかどうかを確認します。
無ければ ファイル→オプション→リボンのユーザー定義 を開いて、開発のところにチェックを入れます。するとリボンの右端に「開発」タブが表示されます。
左端にあるVisual Basic というのをダブルクリックしVisual Basic Editorを起動します。
左端に表示されているプロジェクトのツリーから、今作ったファイルをダブルクリックします。
表示されたツリーのSheet1をダブルクリックします。
右側にそのシートのマクロが表示されます。その中の左上のリストボックスから
Worksheetを選択します。
一番下に、このマクロをコピペします。
保存します。
ブックのほうに戻ります。
AからAKの列の幅を適当に狭くします。数字1個分ぐらいが理想。
ALの幅を広くします。
ここから使い方
A1をダブルクリックしてみましょう。(A1でなくてもいい)
A1に1が表示されB1~AJ1に0が表示され、AK、ALに1が表示されます。
次にA4をダブルクリックします。
A4に1が表示されB1~AJ4に0が表示され、AK1が3に代わりAK2AK3に0AK4に1そしてAL1に3001が表示されます。
次にB2をダブルクリックしてみてください3401に変更されます。
B7をダブルクリックしてみると3504002に変更されます。
A5をダブルクリックすると3501302になります。
C3をダブルクリックすると3571302になります。
B6をダブルクリックすると3471312に。
各列がボール1個に対応していて、1が入っているところが投げるタイミングです。
この場合はAのボールBのボールCのボールがありボール3個のサイトスワップとなるわけです。
次にB5をダブルクリックするとA5が0になりB5に1が入ります。3374112になります。

Re^2: 仕事中でも使えるサイトスワップ作成用エクセルマクロ

No.77: 2015-10-13(火) 00:07:15
投稿者: セバスちゃん
やはりインデントは無視されるようですね。
そのうち機能拡張するかもしれません。
なお、改変は自由です。改変したものを無断でネットに上げても構いません。

エクセルマクロ第2弾

No.84: 2015-10-23(金) 23:19:09
投稿者: セバスちゃん
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim j As Long
Dim k As Long
Dim motoatai As String '入力された値を保存
Dim tasitaatai As String '付け加えてジャグリング可能か調べるための
Dim nagasa As Long
Dim ssbefor(0 To 1000) As String
Dim ssbnum(0 To 1000) As Long
Dim ssafter(0 To 1000) As String
Dim kotaeari As Long
Dim kekka As String '答えを保存するための
Dim sss As Variant '
kekka = ""
sss = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z")

motoatai = Cells(1, 1).Value 'A1に入力された英数字を変数に格納
If Sshantei(motoatai) = 1 Then '入力された値がジャグリング可能かどうか判定、可能なら結果に保存
kekka = motoatai
Else '不可能なら、後ろに英数字を付け加えてジャグリング可能かどうか検証していく
tasitaatai = ""
For i = 0 To 35 '一文字付け加えてジャグリング可能なものがあるか調べていく
tasitaatai = motoatai & sss(i)
If Sshantei(tasitaatai) = 1 Then
kekka = tasitaatai
Exit For

End If
Next i
If kekka = "" Then

For i = 0 To 35 '二文字付け加えてジャグリング可能なものがあるか調べていく
For j = 0 To 35
tasitaatai = motoatai & sss(i) & sss(j)
If Sshantei(tasitaatai) = 1 Then
kekka = tasitaatai
Exit For

End If
Next j
If kekka <> "" Then
Exit For
End If
Next i
End If
If kekka = "" Then

For i = 0 To 35 '三文字付け加えて以下同文
For j = 0 To 35
For k = 0 To 35

tasitaatai = motoatai & sss(i) & sss(j) & sss(k)
If Sshantei(tasitaatai) = 1 Then
kekka = tasitaatai
Exit For

End If
Next k
If kekka <> "" Then
Exit For
End If
Next j
If kekka <> "" Then
Exit For
End If
Next i
End If
End If
If kekka <> Cells(1, 2).Value Then
Cells(1, 2).Value = kekka
End If
'nagasa = Len(motoatai)
'For i = 1 To nagasa
' ssbefor(i) = Mid(motoatai, i, 1)
' For j = 0 To 35
' If sss(j) = ssbefor(i) Then
' ssbnum(i) = j
' End If
' Next j

'Next i


'If Cells(1, 1).Value < 500 Then
'Cells(1, 1).Value = Cells(1, 1).Value + Cells(1, 2).Value
'Cells(2, 1).Value = Cells(2, 1).Value + Cells(1, 2).Value
'Cells(3, 1).Value = Cells(3, 1).Value + Cells(2, 2).Value
'End If
End Sub
Private Function Sshantei(ssmojiretu As String) 'ジャグリング可能かどうか判定するための関数
Dim a As Long
Dim b As Long
Dim itiji As String
Dim ssatai(0 To 1000) As Long
Dim ssikisaki(0 To 1000) As Long
Dim heikin As Long
Dim nagasa As Long
Dim sss As Variant '
Dim hantei As Long
Dim batt(0 To 1000) As Long
hantei = 0
sss = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z")

nagasa = Len(ssmojiretu) '引数の文字列の長さを調べる
For a = 1 To nagasa '一文字ずつ数字に変換して配列に格納
itiji = Mid(ssmojiretu, a, 1)
For b = 0 To 35
If sss(b) = itiji Then
ssatai(a) = b
End If
Next b

Next a
heikin = 0
For a = 1 To nagasa
heikin = heikin + ssatai(a)
Next a
If heikin Mod nagasa = 0 Then '合計÷長さが整数なら次のステップに。違うならばいばいきん
hantei = 1
End If
If hantei = 1 Then
For a = 1 To nagasa '行先変換した値を配列に格納
ssikisaki(a) = ssatai(a) + a
Do While (ssikisaki(a) > nagasa)
ssikisaki(a) = ssikisaki(a) - nagasa
Loop
batt(a) = 0
Next a
For a = 1 To nagasa '行先変換した値がすべて異なるものであるか判定。すべて違うならジャグリング可能なため1を返す。不可能なら0を返す
If batt(ssikisaki(a)) = 0 Then
batt(ssikisaki(a)) = 1
Else
hantei = 0
Exit For
End If
Next a
If hantei = 1 Then
Sshantei = 1
Else
Sshantei = 0

End If
End If
End Function

使い方

No.85: 2015-10-23(金) 23:25:00
投稿者: セバスちゃん
1と同じように貼り付けます。
セルA1に適当な英数字の羅列を入力します。
入力されたものがジャグリング可能ならB1に同じ英数字が表示されます。
不可能なら、その英数字の後ろに1~3文字加えてジャグリング可能なサイトスワップになるかどうかを調べます。あれば、一番最初に
見つかったものが表示されます。
例えば ago と入力したらago00が表示されます。
見つからなければB1は空白のセルになります。

Re: 仕事中でも使えるサイトスワップ作成用エクセルマクロ

No.78: 2015-10-13(火) 15:28:06
投稿者: セバスちゃん
> For a = 1 To 36 'ダブルクリックした行の残りのセルに0を書き込む
> If retu <> a Then
> Cells(gyou, a).Value = 0
> End If
> Next af

すいません、ここ
Next a
です。
コピペするときに加えちゃったみたい(;_;)

動きました!

No.79: 2015-10-17(土) 09:53:10
投稿者: 加藤
古い Windows の古い Excel 環境 (Excel 2000) でも動きました。
マイグレーションが進んでいない会社でも使えます。

なお、インデントが崩れるのは仕様です。

掲示板に戻る