Excelでしりとりを作る方法

Question

いつもお世話になっております。よろしくお願いします。

Excelでしりとりを作りたいです。

100個ほどの単語があるとします。
最初の文字と最後の文字を抽出することが可能ですよね?
それを踏まえてそれらをつないでしりとりを作る事は可能でしょうか?

結果的に100個の単語が全部繋がらなくてもそれは仕方がないのですが、なるべく長くしりとりでつながると理想的です。
極力同じ言葉は二度と使わないようにしたいですが、使うことでしりとりが長くつながるのであればそれはそれで構わないです。

ちなみに添付画像のA2は「き」で繋げ、A14は「じ」で繋ぐというように、いまは後ろから2つ目の文字で繋げていますが、
仲間内で使うだけなので、そのあたりはあいまいでも差支えないです。

できれば関数などで簡単にできれば良いのですが、何かマクロなどを使わないといけなかったりVBなどを使わないといけないのであればなるべく簡単な方法を教えてください。

rukaandkaito · Accepted Answer

おはようございます
ん～～～③のIfIfは恐らくペーストミスだと思いますのでスルーしますが、あとは大体あってる気がします。
ただ書出処理のIf文が上下混在しているようにも受け取れますがｗ
そうなんですよ！
文字数制限がありますので、４０００文字以上は書き込めません。
まあそんなに長いプログラムを作った私のせいですが・・・
なので、私が作成したExcelを下記ＵＲＬよりダウンロードしてみて下さい
https://38.gigafile.nu/0708-dc5b6900d1d02af7fae96d744d2f4f34f
パスワードはありませんが、ダウンロード有効期限は１週間です。

rukaandkaito · Answer

何度も書込みすみません(;´･ω･)
先ほどの修正で先頭文字が指定出来る様になりましたので、処理が終わった際の語句を次に先頭にしていしていけば、重複にはなりますが無限につながっていきますね♪(笑)

rukaandkaito · Answer

No.10です
お待たせしました！
修正は３か所です
①まずはプログラム冒頭のClearContentsの前後に退避と復帰を追加します
--------------------------------------------------------------------------------
　　strB = .Cells(1, 8).Value
　　.Range("H:H").ClearContents
　　.Cells(1, 8).Value = strB
--------------------------------------------------------------------------------
②次に■書出処理■の冒頭部分『If intO = 1 Then』の下の内容を書き換えて下さい
--------------------------------------------------------------------------------
　　　　　　If .Cells(1, 8).Value = "" Then
　　　　　　　　'先頭語句をランダム選出
　　　　　　　　intM = Int(Rnd() * intR)
　　　　　　　　If intM < 1 Then intM = 2
　　　　　　　　strB = .Cells(intM, 2).Value
　　　　　　Else
　　　　　　　　strB = Application.GetPhonetic(.Cells(1, 8).Value)
　　　　　　End If
--------------------------------------------------------------------------------
③最後は最終文字判定の部分
--------------------------------------------------------------------------------
                If Right(strB, 1) = "ル" Or _
                   Right(strB, 1) = "ン" Or _
                   Right(strB, 1) = "ー" Then
                   strL = Left(Right(strB, 2), 1)
                Else
                   strL = Right(strB, 1)
                End If
--------------------------------------------------------------------------------
以上です
変更されたのは『Ｈ１に開始文字を入力してから実行するとその文字から始まる』
というもので、これは一覧に存在しない文字でも構いません。
①はＨ列を初期化していますので、入力文字を一旦退避してクリア後に復元しています。
②は先頭語句をランダム選出していましたが、Ｈ１が入力されている場合にはそのふりがなを取得する。
③は終了文字の除外に『ル』を追加しています。

これでいかがでしょうか？

rukaandkaito · Answer

No.9です
申し訳ありません。補足を見落としていました(;´･ω･)
チョット確認しますね(笑)

rukaandkaito · Answer

No.7に関して
作成済みの表にカーソルを合わせた状態で、『挿入タブ』の『テーブル』を選択すると表がテーブルに変わり見た目も変化します。
この状態の時右端にタブが追加されているはずです。
『テーブルツール』『デザイン』というやつです。
ご確認ください。
No.8に関して
10個前後で終わる！
候補の語句数はいくつくらいありますか？
当方では５５６個の候補を用意し、検証では８０～１１０程度が抽出されました。
仰られているのはＶＢＡではなく関数のみの場合でのことでしょうか？
その場合だと私の方でもその程度の結果でした(;´･ω･)
なので高性能を目指してＶＢＡを作成させていただいた限りです。
処理の度に結果が変動しますので、１００個以下の場合にはやり直してみて下さい。
『開発タブ』『マクロ』『Sample』で動くようになっています。
マクロの利用方法が分からない場合には返信いただければご教授しますよ♪

rukaandkaito · Answer

ムキになったわけではないですが、サンプルコード作ってみました(笑)
Ｃ列以降は不要ですので削除して頂いて構いません
並べ替えた語句はＨ列に表示され、行き詰ると終了します
チョット長いですが、標準モジュールにそのまま張り付ければ動くようになっています
--------------------------------------------------------------------------------
Option Explicit
Option Base 1
Sub Sample()
Dim intR　　As Integer
Dim tblS()  As Variant
Dim intS　　As Integer
Dim tblG()  As Variant
Dim intG　　As Integer
Dim intL　　As Integer
Dim blnC　　As Boolean
Dim intM　　As Integer
Dim tblW(3) As Variant
Dim intO　　As Integer
Dim intD　　As Integer
Dim intB　　As Integer
Dim strB　　As String
Dim strL　　As String
With Sheet1
　　.Range("H:H").ClearContents
　　Application.ScreenUpdating = False
　　Randomize
　　'■初期処理■
　　intR = 2 '先頭行を設定
　　intS = 0 '管理用テーブルカウンタ初期化
　　intG = 0 'データテーブルカウンタ初期化
　　'■退避処理■
　　'最終語句まで読込
　　Do Until .Cells(intR, 2).Value = ""
　　　　'先頭文字の比較を行いそれぞれの件数を取得
　　　　blnC = False
　　　　For intL = 1 To intS
　　　　　　'先頭文字が一致したらカウントアップ
　　　　　　If Left(.Cells(intR, 2).Value, 1) = tblS(1, intL) Then
　　　　　　　　tblS(2, intL) = tblS(2, intL) + 1
　　　　　　　　tblS(3, intL) = tblS(2, intL)
　　　　　　　　blnC = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next intL
　　　　'一致しなかったら新規レコード作成
　　　　If blnC = False Then
　　　　　　intS = intS + 1
　　　　　　ReDim Preserve tblS(3, intS)
　　　　　　tblS(1, intS) = Left(.Cells(intR, 2).Value, 1)
　　　　　　tblS(2, intS) = 1
　　　　　　tblS(3, intS) = tblS(2, intS)
　　　　End If
　　　　'データテーブル最大値まで拡張
　　　　If intG < tblS(2, intL) Then
　　　　　　intG = intG + 1
　　　　　　ReDim Preserve tblG(100, 4, intG)
　　　　End If
　　　　'データ一時退避
　　　　tblG(intL, 1, tblS(2, intL)) = tblS(2, intL)
　　　　tblG(intL, 2, tblS(2, intL)) = Rnd()
　　　　tblG(intL, 3, tblS(2, intL)) = .Cells(intR, 1).Value
　　　　tblG(intL, 4, tblS(2, intL)) = .Cells(intR, 2).Value
　　　　'ランダムソート処理
　　　　If tblS(2, intL) < 2 Then
　　　　Else
　　　　　　For intM = tblS(2, intL) To 2 Step -1
　　　　　　　　If tblG(intS, 2, intM) < tblG(intS, 2, intM - 1) Then
　　　　　　　　　　tblW(1) = tblG(intL, 2, intM - 1)
　　　　　　　　　　tblW(2) = tblG(intL, 3, intM - 1)
　　　　　　　　　　tblW(3) = tblG(intL, 4, intM - 1)
　　　　　　　　　　tblG(intL, 2, intM - 1) = tblG(intL, 2, intM)
　　　　　　　　　　tblG(intL, 3, intM - 1) = tblG(intL, 3, intM)
　　　　　　　　　　tblG(intL, 4, intM - 1) = tblG(intL, 4, intM)
　　　　　　　　　　tblG(intL, 2, intM) = tblW(1)
　　　　　　　　　　tblG(intL, 3, intM) = tblW(2)
　　　　　　　　　　tblG(intL, 4, intM) = tblW(3)
　　　　　　　　End If
　　　　　　Next intM
　　　　End If
　　　　'次の行データ
　　　　intR = intR + 1
　　Loop
　　'■書出処理■
　　intO = 1
　　Do
　　　　If intO = 1 Then
　　　　　　'先頭語句をランダム選出
　　　　　　intM = Int(Rnd() * intR)
　　　　　　If intM < 1 Then intM = 2
　　　　　　strB = .Cells(intM, 2).Value
　　　　　　'管理テーブル検索
　　　　　　For intL = 1 To intS
　　　　　　　　If Left(strB, 1) = tblS(1, intL) Then
　　　　　　　　　　tblS(3, intL) = tblS(3, intL) - 1
　　　　　　　　　　If tblS(3, intL) = 0 Then Exit Do
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next intL
　　　　　　'データテーブル検索
　　　　　　For intD = 1 To tblS(3, intL) + 1
　　　　　　　　If strB = tblG(intL, 4, intD) Then
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next intD
　　　　Else
　　　　　　'管理テーブル検索
　　　　　　For intL = 1 To intS
　　　　　　　　If Right(strB, 1) = "ン" Or _
　　　　　　　　   Right(strB, 1) = "ー" Then
　　　　　　　　   strL = Left(Right(strB, 2), 1)
　　　　　　　　Else
　　　　　　　　   strL = Right(strB, 1)
　　　　　　　　End If
　　　　　　　　If strL = tblS(1, intL) Then
　　　　　　　　　　tblS(3, intL) = tblS(3, intL) - 1
　　　　　　　　　　If tblS(3, intL) = 0 Then Exit Do
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next intL
　　　　　　'データテーブル検索
　　　　　　intD = Int(Rnd() * tblS(3, intL) + 1)
　　　　　　strB = tblG(intL, 4, intD)
　　　　End If
　　　　intO = intO + 1
　　　　.Cells(intO, 8).Value = tblG(intL, 3, intD)
　　　　'対象データ削除処理
　　　　For intB = intD To tblS(3, intL)
　　　　　　tblG(intL, 2, intB) = tblG(intL, 2, intB + 1)
　　　　　　tblG(intL, 3, intB) = tblG(intL, 3, intB + 1)
　　　　　　tblG(intL, 4, intB) = tblG(intL, 4, intB + 1)
　　　　Next intB
　　　　tblG(intL, 1, tblS(3, intL) + 1) = 0
　　　　tblG(intL, 2, tblS(3, intL) + 1) = 0
　　　　tblG(intL, 3, tblS(3, intL) + 1) = ""
　　　　tblG(intL, 4, tblS(3, intL) + 1) = ""
　　Loop
　　Application.ScreenUpdating = True
End With
End Sub
--------------------------------------------------------------------------------
解説用になるべくコメント付けています。お試しください

rukaandkaito · Answer

No.4です
H3：=INDEX($A:$A,INDEX(テーブル1,MATCH($I2,$A:$A,0)-1,6))
ここでエラーになるのですか？
すみません(;´･ω･)テーブル1という部分ですが、作成した表を挿入タブのテーブルに変換してました(笑)
そこで作成したテーブル名（テーブルツールタブのデザイン）を『テーブル1』にしています。ちなみにテーブル範囲はA～Hです。お試しください

WindFaller · Answer

私も考えてみました。
>100個ほどの単語があるとします。
VBAでつくってみたものの、何かバグを抱えているようで、発表するには、まだもうひとつというところと、メモリの中で、処理するのか、セル上に書き出して使うのか、二者択一で迷っている状態です。書き出した方がよいには決まっています。ただ、処理するところが、なんとなく間が抜けているような気がします。一部の仕様は、下の内容と同じです。

添付画像は、マクロで出来たリスト。（見て分かる通り、全部のリストに充実していないけば、ネタ切れになってしまいます。)

本来は、人間との対戦型にしたいと考えました。
　・その単語が、動詞や形容詞は不可とする。名詞か固有名詞に限ることにする。
　・PC側の辞書は、50音の内、（ん・を)を除いた用語を用意する。
　・架空の単語ではダメなので、インターネット検索で、例えば、gooの辞書を使い、判定する。
　・語尾の「ん」は、負けとする。
　最初、AIかと思いましたが、AIとは言えません。ただ、こちらの方は、出来上がるのに相当の時間が掛かりそうです。

rukaandkaito · Answer

No.4です
この並べ替えではっきり分かりましたが
この方法だとあまり良い結果が得られませんね・・・
本来であればVBAで作成し、既に選択された語句は削除していく方法が好ましいのだと思います。
関数でやるのであればここら辺が限界なのでしょうか
もしかしたら他にもっと良い方法があるかもしれませんので、質問を継続しては如何でしょう・・・

お力になれず申し訳ありませんm(T^T)m

rukaandkaito · Answer

では並べてみましょう
H2：=A2
H3：=INDEX($A:$A,INDEX(テーブル1,MATCH($I2,$A:$A,0)-1,6))
H4以降はH3をフィルしてください

Excelでしりとりを作る方法

おはようございます

何度も書込みすみません(;´･ω･)

No.10です

No.9です

No.7に関して

ムキになったわけではないですが、サンプルコード作ってみました(笑)

No.4です

私も考えてみました。

No.4です

では並べてみましょう

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング