短文をランダムに組み合わせ、長文を作りたい

質問

エクセル初心者です。
オフィス2003を使用しています。

sheet1のＡ列の１行目～３３行目に
Ａ１セル＝今日は天気が良い。朝から気温は２５度もある。
Ａ２セル＝体の調子は快調だ。気分もウキウキする。
Ａ３セル＝海水浴に出かけたいが、遠出は難しい。
・・・・
といった短文があります。

これをランダムに４～５個抽出して、
すべて異なる長文を340通り作成したいと思います。
（文の順序はバラバラでかまいません。）

マクロを使用し、

Sub test03()
Dim myRng As Range '変数宣言
Dim myDic As Object
Dim x As Integer, i As Integer, myStr As String, v As String

Randomize '乱数初期化
Set myRng = Sheets("Sheet1").Range("A1:A33") 'データ範囲
Set myDic = CreateObject("Scripting.Dictionary") 'オブジェクト準備

Do Until myDic.Count = 340 'ユニークで340そろうまで
x = Int(2 * Rnd) + 4 '乱数で個数設定（4～5）
myStr = ""
i = 0
Do Until i = x '指定個数になるまで
v = myRng(Int(33 * Rnd) + 1) '乱数でセル選択
If InStr(myStr, v) = 0 Then '文字列内で重複がなければ
myStr = myStr & v '文字列につなげる
i = i + 1 'カウント
End If
Loop '繰り返し
If Not myDic.exists(myStr) Then '重複しなければ
myDic.Add myStr, x '収録
End If
Loop '繰り返し

Sheets("Sheet2").Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys) '転記
End Sub

上記のように入力してみたのですが、
実行時エラー
型が一致しませんという表示が出て

Sheets("Sheet2").Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys) '転記

の部分が指定？されているのですが、
どこを直したらいいのかわかりません。

２～３個抽出するだけだと上の式で
できるのですが、
４～５個の抽出にするとうまくできません。

訂正の仕方を教えてください。

回答No.3

merlionXX · ベストアンサー

どうも配列に取り込みTransposeで変換する際に256文字以上の文字列がエラーに引っかかるようです。それなら簡単な解決策を思いつきました。
原始的ですが配列を用いず、直接セルに一個ずつ入力させれば大丈夫でした。（若干スピードが落ちますが）

Sub test05()
Dim myRng As Range '変数宣言
Dim myDic As Object
Dim x As Integer, i As Integer, myStr As String, v As String
Dim n As Long

Randomize '乱数初期化
Set myRng = Sheets("Sheet1").Range("A1:A33") 'データ範囲
Set myDic = CreateObject("Scripting.Dictionary") 'オブジェクト準備

Do Until myDic.Count = 340 'ユニークで340そろうまで
x = Int(2 * Rnd) + 4 '乱数で個数設定（4～5）
myStr = ""
i = 0
Do Until i = x '指定個数になるまで
v = myRng(Int(33 * Rnd) + 1) '乱数でセル選択
If InStr(myStr, v) = 0 Then '文字列内で重複がなければ
myStr = myStr & v '文字列につなげる
i = i + 1 'カウント
End If
Loop '繰り返し
If Not myDic.exists(myStr) Then '重複しなければ
myDic.Add myStr, x '収録
n = n + 1
Sheets("Sheet2").Cells(n, "B").Value = myStr 'Sheet2に直接記入
End If
Loop '繰り返し

End Sub

お礼

何度もお手間おかけしました。

おかげさまで目的のものができました♪
スピードも全然問題ありませんでした。

またの機会がありましたら、ぜひご教授いただければと思います。

本当にありがとうございました。

回答No.2

merlionXX

> 想定される文字数も２００～４００文字くらいなので

原因はこれのようです。
ためしに255文字で切って見るとエラーにはならないと思います。

Sub test04()
Dim myRng As Range '変数宣言
Dim myDic As Object
Dim x As Integer, i As Integer, myStr As String, v As String

Randomize '乱数初期化
Set myRng = Sheets("Sheet1").Range("A1:A33") 'データ範囲
Set myDic = CreateObject("Scripting.Dictionary") 'オブジェクト準備

Do Until myDic.Count = 340 'ユニークで340そろうまで
x = Int(2 * Rnd) + 4 '乱数で個数設定（4～5）
myStr = ""
i = 0
Do Until i = x '指定個数になるまで
v = myRng(Int(33 * Rnd) + 1) '乱数でセル選択

If InStr(myStr, v) = 0 Then '文字列内で重複がなければ
myStr = myStr & v '文字列につなげる
myStr = Left(myStr, 255) '256文字以上はエラー
i = i + 1 'カウント
End If
Loop '繰り返し
If Not myDic.exists(myStr) Then '重複しなければ
myDic.Add myStr, x '収録
End If
Loop '繰り返し

Sheets("Sheet2").Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys) '転記
End Sub

役にはたちませんが・・・・。
また別の方法を考えます。少し時間をください。

回答No.1

merlionXX

nori213さんこんいちは。
またお会いしましたね。

ご提示のコードをそのままコピペしてやってみましたが正常に作動しましたよ。
エラーがでるとしたらSheet1のデータの中にエラー値が混じってないですか？

補足

merlionXXさん、いつもありがとうございます。

前回教えていただいたマクロは
非常に使えて重宝してます(*^ ^*)

念のため、
マクロで使う部分だけを新規にエクセルで作成して
何度かやってみたのですが、
同じ結果でした。

１つのセルに入る文字数を少なくしてみると
上の式で問題なく動作するのですが、
長文になると
なぜか上記のエラーが出てしまいます。

実際に使う短文が
ホームページ用のタグ
例えば<br>,<font>などを含んでいることが原因なのでしょうか？

ただ、この場合でも
抽出数を２～３個にすると問題なく動作しますし、
４～５個抽出した場合に想定される文字数も２００～４００文字くらいなので、特に問題はないと思われます。

ちなみに「Sheet1のデータの中にエラー値」というのは
どういったものがエラー値になるのでしょうか？