人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excel(エクセル)2007のVBAで、
「極力重複しないランダム置換プログラム」になるように作成途中のソースを修正してほしいです。
文字数制限の関係で、ここに書ききれない部分を、最後に「補足」としてリンク先に書きましたのでどうか読んでください。



手順

?A列に「置換前のデータ」を含んだ文章入力。
A1:(動物)と(動物)が好き
A2:(動物)と(動物)と(動物)は可愛い。だから(動物)と(動物)と(動物)が好き


?B列に"(動物)"の「置換後のデータ」入力。
B1:犬
B2:猫
B3:鳥


?コマンドボタンで
A列の"(動物)"を、B列の"犬"と"猫"と"鳥"のどれか1つで必ず置換して
その結果を「C列」に表示。
それも、重複しないランダム置換です。



※作成途中のソース※(修正してほしいソースです。)

http://kanzentaini4.com/test1.html



※※補足※※(必ず読んでいただきたいです。)

http://kanzentaini4.com/hosoku.html



分かる方、できる方いましたら修正したソースを教えてください。
どうかよろしくお願いします。



●質問者: ヘンリ
●カテゴリ:コンピュータ インターネット
✍キーワード:?B A1 b2 Excel VBA
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●100ポイント

ほとんど原形をとどめていませんが、面白そうなので作成してみました。

一応動作確認してありますが、問題がありましたらコメント対応しますので、

下記の「この質問・回答へのコメント」を有効にお願いします。

Option Explicit

Private Sub CommandButton1_Click()
 Const searchWord = "(動物)"  '// 置換する検索語

 With ThisWorkbook.Sheets("Sheet1")
  '// 置換対象の配列の作成
 Dim CellA As Range
 Dim res As String
 Dim replaceArray As Variant
 For Each CellA In .Range("B1").Resize(.Range("B" & .Rows.Count).End(xlUp).Row, 1)
 If res = "" Then
 res = CellA.Value
 Else
 res = res & "/" & CellA.Value
 End If
 Next
 replaceArray = Split(res, "/")
 
  '// 置換処理
 Dim pArray As Variant
 Dim arrayIndex As Long
 Dim i As Long
 For Each CellA In .Range("A1").Resize(.Range("A" & .Rows.Count).End(xlUp).Row, 1)
  '// 配列のシャッフル
 arrayIndex = 0
 shuffleArray replaceArray
 pArray = Split(CellA, searchWord)
 res = pArray(0)
 For i = 1 To UBound(pArray)
 res = res & replaceArray(arrayIndex) & pArray(i)
 arrayIndex = arrayIndex + 1
 If arrayIndex > UBound(replaceArray) Then
  '// 一巡したら配列を再シャッフル
 arrayIndex = 0
 shuffleArray replaceArray
 End If
 Next
 CellA.Offset(0, 2).Value = res
 Next
 End With
End Sub

'// 検索語を並べ替える
Sub shuffleArray(wordArray)
 Dim r As Long
 r = UBound(wordArray)

 Dim i As Long, j As Long, s As Long, t As String
 For i = 1 To 3
 For j = 0 To r
 s = Int(Rnd() * (r + 1))
 t = wordArray(s)
 wordArray(s) = wordArray(j)
 wordArray(j) = t
 Next
 Next
End Sub
◎質問者からの返答

Mook さん

私のやりたいことが完璧にできていました。

エラーもありません。

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

ずっと悩んでいたので、嬉しいです。


実はここからもう1つやりたいことがありまして、

Mookさんのソースをかなりいじってたのですが、

どうしても置換してくれるところと置換してくれないところがまざってしまったりエラーになるので、どうにか次のようなソースも教えていただけないでしょうか。

一言でいいますと、重複しないランダム置換機能はそのままに、

「置換前のデータ」を増やしていきたいのです。

具体的には



「A列」

A1:(動物)と(動物)が(好き)

A2:(動物)と(動物)と(動物)は(可愛い)。だから(動物)と(動物)と(動物)が(好き)


「B列」:"(動物)"の「置換後のデータ」

B1:犬

B2:猫

B3:鳥


「C列」:"(好き)"の「置換後のデータ」

C1:好き

C2:大好き

C3:気に入っている


「D列」:"(可愛い)"の「置換後のデータ」

D1:可愛い

D2:かわいい

D3:カワイイ


※「E列」にランダム置換結果を表示。


↑のような感じで、A列の文章の「ランダム置換できる箇所」を増やしていきたいのです。

上記の、

>「A列」

>A1:(動物)と(動物)が(好き)

>A2:(動物)と(動物)と(動物)は(可愛い)。だから(動物)と(動物)と(動物)が(好き)

もあくまで例文なのですが

この例文の場合

新たに追加する2つの

●「C列」:"(好き)"の「置換後のデータ」

C1:好き

C2:大好き

C3:気に入っている


●「D列」:"(可愛い)"の「置換後のデータ」

D1:可愛い

D2:かわいい

D3:カワイイ

↑これらもランダム置換するためには、上記で教えていただいたソースにどのように組み込めばいいのでしょうか。

組み込んだソースで教えていただきたいのです。

(この先もどうか読んで欲しいです。)

↓↓↓


※このプログラムでどうしても守りたいのが

ランダム置換処理する順番なんですが、

エクセルの列の並び順(ABCDE・・・という左から右への順番)通りに処理するようにしたいです。


具体的には

「置換後のデータ」にランダム置換する順番が、

●「B列:(動物)」のランダム置換→「C列:(好き)」のランダム置換→「D列:(可愛い)」のランダム置換→・・・

のようになればいいなと思っています。

なので、同時に

●「A列の"(動物)"がランダム置換された文章」をE列に表示

「E列の"(好き)"もランダム置換された文章」をE列に表示

「E列の"(可愛い)"もランダム置換された文章」をE列に表示

という処理の順番になると思います。



Mook さん

もし時間ができましたら、

どうかこれらの条件を満たすVBAソースをよろしくおねがいいたします。

「この質問・回答へのコメント」欄にここまでを書いてしまうと、

回答ポイントもあげないで教えていただくことになるので、

「この回答に返信する」欄に書かせていただきました。


2 ● Mook
●100ポイント ベストアンサー

ポイントは自由に変更できるので、コメント文での追加回答を最初の回答に上乗せしていただくこともできます。

私としては一回当たりのポイントが気になっているので、2回で70ptより1回で60ptの方が嬉しいです。

仕様の確認をしたいこともありますので、いずれにせよコメント欄は有効にお願いします。


さて、同じような処理を繰り返したい場合は、パターン化すると処理がシンプルになります。

関数が増えるのは面倒そうですが、同じことを繰り返し書かなくてよいので、全体の

管理が楽になりますし、今回の変更でかえってコードが見やすくなったのではないかと思います。


Option Explicit

'// コマンドボタン処理
'//-----------------------------------
Private Sub CommandButton1_Click()
 Dim replaceArrayB As Variant
 Dim replaceArrayC As Variant
 Dim replaceArrayD As Variant
 
 With ThisWorkbook.Sheets("Sheet1")
 replaceArrayB = makeArray(.Range("B1").Resize(.Range("B" & .Rows.Count).End(xlUp).Row, 1))
 replaceArrayC = makeArray(.Range("C1").Resize(.Range("C" & .Rows.Count).End(xlUp).Row, 1))
 replaceArrayD = makeArray(.Range("D1").Resize(.Range("D" & .Rows.Count).End(xlUp).Row, 1))
 
 Dim CellA As Range
 Dim res As String
 For Each CellA In .Range("A1").Resize(.Range("A" & .Rows.Count).End(xlUp).Row, 1)
 res = replacePhrase(CellA.Value, "(動物)", replaceArrayB)
 res = replacePhrase(res, "(好き)", replaceArrayC)
 CellA.Offset(0, 4).Value = replacePhrase(res, "(可愛い)", replaceArrayD)
 Next
 End With
End Sub

'// 配列を使用してランダムに置き換え
'//-----------------------------------
Function replacePhrase(phrase, searchWord, replaceArray)
 Dim pArray As Variant
 Dim arrayIndex As Long
 Dim i As Long
 
  '// 配列のシャッフル
 arrayIndex = 0
 shuffleArray replaceArray
 pArray = Split(phrase, searchWord)
 replacePhrase = pArray(0)
 For i = 1 To UBound(pArray)
 replacePhrase = replacePhrase & replaceArray(arrayIndex) & pArray(i)
 arrayIndex = arrayIndex + 1
 If arrayIndex > UBound(replaceArray) Then
  '// 一巡したら配列を再シャッフル
 arrayIndex = 0
 shuffleArray replaceArray
 End If
 Next
End Function

'// 指定したレンジから配列に作成
'//-----------------------------------
Function makeArray(wordRange)
 Dim r As Range
 Dim res As String
 
 For Each r In wordRange
 If res = "" Then
 res = r.Value
 Else
 res = res & "/" & r.Value
 End If
 Next
 makeArray = Split(res, "/")
End Function

'// 配列の単語を並べ替える
'//-----------------------------------
Sub shuffleArray(wordArray)
 Dim r As Long
 r = UBound(wordArray)

 Dim i As Long, j As Long, s As Long, t As String
 For i = 1 To 3 '// 気持ちだけ多めにシャッフル:省略も可。
 For j = 0 To r
 s = Int(Rnd() * (r + 1))
 t = wordArray(s)
 wordArray(s) = wordArray(j)
 wordArray(j) = t
 Next
 Next
End Sub
◎質問者からの返答

Mookさんへ

こんなに早く的確なコードを考えていただき、大変ありがたいです。

今回もまた、何度試してもエラーもなく希望通りの処理結果になるのですごく嬉しいかぎりです。

感動しています!

それからポイントシステムの特性について、わかりやすく色々教えていただきありがとうございます。

とりあえずコメント欄の有効を優先させていただきますので、どうぞよろしくおねがいいたします。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ