サイトスワップ掲示板

エクセルマクロ第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

関連ツリー

【1】 仕事中でも使えるサイトスワップ作成用エクセルマクロ No.75 セバスちゃん 2015-10-13(火) 00:01:04
Re: 仕事中でも使えるサイトスワップ作成用エクセルマクロ No.76 セバスちゃん 2015-10-13(火) 00:03:30
Re^2: 仕事中でも使えるサイトスワップ作成用エクセルマクロ No.77 セバスちゃん 2015-10-13(火) 00:07:15
エクセルマクロ第2弾 No.84 セバスちゃん 2015-10-23(金) 23:19:09
使い方 No.85 セバスちゃん 2015-10-23(金) 23:25:00
Re: 仕事中でも使えるサイトスワップ作成用エクセルマクロ No.78 セバスちゃん 2015-10-13(火) 15:28:06
動きました! No.79 加藤 2015-10-17(土) 09:53:10

掲示板に戻る