Excel2007VBAのランダム置換ソース

質問

Excel（エクセル）2007VBAを使って、
「複数ある、同一の置換したい文字・数」 を 「複数の文字・数」 でランダムに置換したいのですが、
VBAソースが分かりません。

たとえば、

【A列】に
A1:私は(置換する所)と(置換する所)が得意です。
A2:彼は(置換する所)と(置換する所)と(置換する所)が特技です。
A3:彼女は(置換する所)と(置換する所)と(置換する所)と(置換する所)の選手です。
A4:彼らは(置換する所)と(置換する所)と(置換する所)と(置換する所)と(置換する所)が好きです。
A5:あの人は(置換する所)と(置換する所)と(置換する所)と(置換する所)と(置換する所)と(置換する所)をしたことがありません。

と入力されている時に、

【B列】に
B1:拳闘
B2:柔道
B3:野球
B4:籠球
B5:打球
B6:羽球
B7:剣道
B8:卓球
B9:水泳
B10:避球

と入力したとします。

そして、コマンドボタンを押すと
【A列】にあるすべての 「(置換する所)」 を、 【B列】にある「拳闘」「柔道」「野球」「籠球」「打球」「羽球」「剣道」「卓球」「水泳」「避球」のどれかで必ず置換されるようにします(【ランダムで置換】されるようにしたいです)。

※置換の条件として、一つのセル内で同じ文字が重複しないようにしたいです。
(私は拳闘と拳闘が得意です。)
　　　　↑　　　↑
同じ文字が2つ以上ある置換は失敗です。

---------------------------------
置換の成功例 (重複なしの置換)

◆置換前の【A列】A5
あの人は(置換する所)と(置換する所)と(置換する所)と(置換する所)と(置換する所)と(置換する所)をしたことがありません。
　　　　　　↓↓↓
◆置換後の【A列】A5
あの人は打球と柔道と水泳と剣道と避球と拳闘をしたことがありません。
---------------------------------

これが未完成のVBAソースです。
↓↓↓
Sub test_Click()
For Each CellA In Range("A1:A5").Cells
Rnd1 = Int(Rnd() * 10) + 1
Rnd2 = Int(Rnd() * 9) + 1
Rnd3 = Int(Rnd() * 8) + 1
Rnd4 = Int(Rnd() * 7) + 1
Rnd5 = Int(Rnd() * 6) + 1
Rnd6 = Int(Rnd() * 5) + 1
If Rnd2 = Rnd1 Then Rnd2 = Rnd2 + 1
If Rnd3 = Rnd2 Then Rnd3 = Rnd3 + 1
If Rnd4 = Rnd3 Then Rnd4 = Rnd4 + 1
If Rnd5 = Rnd4 Then Rnd5 = Rnd5 + 1
If Rnd6 = Rnd5 Then Rnd6 = Rnd6 + 1
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd1, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd2, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd3, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd4, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd5, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd6, 2), , 1)
Next
End Sub

【補足】
※コマンドボタンを押すとランダム置換される仕様です。
※１回限定の置換ではなく、コマンドボタンを押すたびに(何度でも)ランダム置換できるようにしたいです。
※上記の【A列】【B列】の文字はあくまで例です。実際は、【A列】【B列】ともに自由に文字を変更できる応用の利く仕様にしたいです(Excelの【A列】【B列】に、文字を直接入力して変更するという意味です)。
※上記の【A列】が5行、【B列】が10行というのもあくまで例です。実際は、【A列】【B列】ともに何行にでも対応できる仕様にしたいです(具体的には【A列】【B列】ともに、10000行くらいまで対応できるのが理想です)。

長くなりましたが、ここまでの条件を満たすVBAソースが知りたいです。
どうかよろしくおねがいいたします。

回答No.4

ki-aaa · ベストアンサー

こんにちわ

>※１回限定の置換ではなく、コマンドボタンを押すたびに(何度でも)ランダム置換できるようにしたいです。・・・とあるので、C列にコピーして処理しています。

Sub test_Click1()
Dim gyo As Long, rnd1 As Long
Dim sss As String, ttt As String
Dim CellA As Range
With ThisWorkbook.Sheets("Sheet1")
.Range("A:A").Copy .Range("C1")
gyo = .Range("B" & Rows.Count).End(xlUp).Row
For Each CellA In .Range("C1:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
sss = ""
Do Until InStr(CellA.Value, "(置換する所)") = 0
Do '重複チェック
rnd1 = Int(Rnd() * gyo) + 1
ttt = .Range("B" & rnd1).Value
If InStr(sss, ttt) = 0 Then
sss = sss & "," & ttt
Exit Do
End If
Loop
CellA.Value = Replace(CellA.Value, "(置換する所)", ttt, , 1)
Loop
Next CellA
End With
End Sub

お礼

ki-aaaさん

回答していただき、ありがとうございます。
VBAソース、とても参考になりました。

1行目の「Sub test_Click1()」を「Sub test_Click()」に変えてからコピペしただけでエラーなく、とてもスムーズに動いて驚きました。

思わず何度もコマンドボタン押しちゃいました。
すごく助かりました。
感謝です。

回答No.7

n-jun

Ｎｏ５です。

まずｔｒｙ１とｔｒｙ２用に２つのボタンを配置します。

ｔｒｙ１　が　Sub test_Click()～Ｅｎｄ　Sｕｂ
ｔｒｙ２　が　Sub reset_Click()～End　Sub

みたいしにして、それぞれに中のコードをコピペします。

あとは　Sub test_Click()　の上に

Private vv As Variant
Private ch As Boolean

をコピペしてみて下さい。

お礼

n-junさん

何度も教えていただきありがとうございます。

素直に何度かやってみました。
エラーは出なかったのですが、何も起きなかったです。

でも、わざわざアドバイスくださり嬉しいです。
感謝です。

回答No.6

Wendy02

B列が10000行あるということですから、高速化をさせるために、置換文字列数を数えて、B列から重複のない数字を抜き出します。

データを元に戻す用意もしました。

'//
Sub TestReplace()
　'Private Sub CommandButton1_Click()
　Const sFND As String = "(" '置換対象の検索する文字（1文字）
　Dim rng As Range
　Dim i As Long, j As Long, k As Long, m As Long
　Dim Ar As Variant
　Dim arRnd() As Long '乱数を入れる
　Dim LastCnt As Long
　Dim newSht As Worksheet, ACsht As Worksheet, dum As Variant
　'A列
　Set ACsht = ActiveSheet
　Set rng = ACsht.Range("A1", Cells(Rows.Count, 1).End(xlUp))
　On Error Resume Next
　dum = Worksheets("Backup").Range("A1").Value
　If Err.Number > 0 Then
　　With ActiveWorkbook
　　　Set newSht = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
　　　newSht.Name = "Backup"
　　　ACsht.Activate
　　End With
　End If
　If dum <> "" Then
　　newSht.Range("A1").CurrentRegion.Clear
　End If
　rng.Copy newSht.Range("A1")
　On Error GoTo 0
　With ACsht
　LastCnt = .Cells(Rows.Count, 1).End(xlUp).Row
　'B列
　Ar = Application.Transpose(.Range("B1", .Cells(Rows.Count, 2).End(xlUp)).Value)
　m = UBound(Ar) '最終行
　ReDim arRnd(m - 1)
　Application.ScreenUpdating = False
　Randomize '←乱数プレートは1回に1回の交換
　For i = 1 To LastCnt
　　j = Len(.Cells(i, 1).Value) - Len(Replace(.Cells(i, 1).Value, sFND, "", , , 1))
　　RngMaking arRnd, j
　　For k = 1 To j
　　　.Cells(i, 1).Value = Replace(.Cells(i, 1).Value, "(置換する所)", Ar(arRnd(k) + 1), , 1, 1)
　　Next k
　Next i
　Application.ScreenUpdating = True
　End With
End Sub
Sub RngMaking(arRnd() As Long, ByVal cut As Integer)
'乱数生成
　Dim LastCnt As Long
　Dim i As Long, k As Long, n As Long
　Dim Ret As Variant
　LastCnt = UBound(arRnd)
　ReDim arRnd(LastCnt)
　Do
　　n = Int(Rnd() * LastCnt) + 1
　　Ret = Application.Match(n, arRnd, 0)
　　If IsError(Ret) Then
　　　arRnd(i) = n
　　　If (i + 1) >= cut Then Exit Sub　'乱数の収得の中止
　　　i = i + 1
　　End If
　　'ハング防止
　　k = k + 1: If k > LastCnt ^ 4 Then MsgBox "Unknown Error", 36: End
　Loop Until i > LastCnt - 1
End Sub
Sub DataBack()
'データ戻し
　Worksheets("Backup").Range("A1").CurrentRegion.Resize(, 1).Copy _
　ActiveSheet.Range("A1")
End Sub

お礼

Wendy02さん

丁寧に配慮の行きとどいたソースを教えていただき、ありがとうございます。

試しに、上記で教えていただいたソースをコピペしてからコマンドボタンを押してみたのですが、何も起きず申し訳ないです。

そもそも私が見当違いのことをしているため、なにも起きないという事態を招いたと思うのですが、分からないことだらけで補足のしようがないので、いつかWendy02さんから教えていただいたソースを活かせられるように地道に前進していきます。

エラーなく動いた場合、かなり使えそうなソースだっただけに、今はただただ使いこなせず申し訳ありません。

Wendy02さん
今回は貴重で入念なVBAソース、本当にありがとうございます。
感謝です。

回答No.5

n-jun

Ｎｏ３です。

1万行はどうかわかりませんが。

Private vv As Variant
Private ch As Boolean

Sub try1()
Dim r As Range
Dim st1 As String
Dim st2 As String
Dim st As String
Dim i As Integer
Dim m As Long
Dim v As Variant

vv = Range("A1", Cells(Rows.Count, 1).End(xlUp))
ch = True

For Each r In Range("A1", Cells(Rows.Count, 1).End(xlUp))

v = Split(r.Value, "(置換する所)")
Randomize
st = ""
st2 = ""

For i = 0 To UBound(v) - 1

Do
m = Int(Rnd() * Cells(Rows.Count, 2).End(xlUp).Row) + 1
st1 = Range("B" & m).Value
Loop Until InStr(st2, st1) = 0
st2 = st2 & st1 & ","

st = st & v(i) & st1

Next
r.Value = st & v(i)

Next

End Sub

' ---戻す時---（ただし1回だけ）
Sub try2()

If ch Then
Range("A1").Resize(UBound(vv), 1).Value = vv
Erase vv: ch = False
End If

End Sub

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

try1　をまず実行して置換をします。
try2　で元に戻します。
ただし先に try2　を実行したり、連続で try2　を実行するとエラーになるでしょう。。。

お礼

n-junさん

何度もお世話になっております。
ありがとうございます。

ものすごく恥ずかしいこと書いてしまうのですが、
実は私、「try1」や「try2」の"try"を実行すると意味が分かっておりません。

"try"はコマンドボタンを押すという意味ではないようですね(恥)
せっかく幾度も教えていただいたソースを何度もコピペしてから、コマンドボタンを押してみても何も起こらないです。

試しに、「Sub try1()」の部分を「Sub test_Click()」に変えてからコマンドボタンを押すも、A列が一回置換されるだけだったりして、本当申し訳ないです。

質問する側の能力が低過ぎて、n-junさんの回答を生かしきれず申し訳ありません。

今はコマンドボタンを設置して、そのコマンドボタンを押すことで
VBAソースの内容を作動できるくらいしか、VBAについて分かっておりません。しかもソース記述に必要な～構文なども全く分かりません。

そんなわけで、いろいろ恥しいことを書いてしまったのですが、
いつか役に立つであろうソースを書いていただき、ありがとうございます。
感謝です。

回答No.3

n-jun

Ｎｏ２です。

Ｎｏ２の内容は特に問題にならなければ。

Sub try()
Dim r As Range
Dim st1 As String
Dim st2 As String
Dim st As String
Dim i As Integer
Dim m As Long
Dim v As Variant

For Each r In Range("A1", Cells(Rows.Count, 1).End(xlUp))

v = Split(r.Value, "(置換する所)")
Randomize
st = ""
st2 = ""

For i = 0 To UBound(v) - 1

Do
m = Int(Rnd() * Cells(Rows.Count, 2).End(xlUp).Row) + 1
st1 = Range("B" & m).Value
Loop Until InStr(st2, st1) = 0
st2 = st2 & st1 & ","

st = st & v(i) & st1

Next
r.Value = st & v(i)

Next

End Sub

一例まで。

お礼

No.3(n-jun)さん

お答えいただきありがとうございます。
ソース、参考にさせていただきます。

今はまだ、教えていただいたソースをどう使ったらいいのか正直分かっていないのですが、感謝します。

回答No.2

n-jun

知恵袋でも気になりましたけど。

＞１回限定の置換ではなく、コマンドボタンを押すたびに(何度でも)ランダム置換できるようにしたいです。
の条件を満たすには、Ａ列の文章を置換したあと元に戻すコードも必要って事ですか？

普通に作ると１回置換したら置換後の文章になりますよね？
あるいはＡ列のデータをどこかにかコピペしても良いと言うこと？

補足

n-junさん

知恵袋でも見ていただいてありがとうございます。

>Ａ列の文章を置換したあと元に戻すコードも必要って事ですか？
はい。できれば、置換したあと元に戻すコードが知りたいです。

>普通に作ると１回置換したら置換後の文章になりますよね？
はい。やはりそうなってしまいます。

>あるいはＡ列のデータをどこかにかコピペしても良いと言うこと？
あらかじめ、A列に貼りつけるデータがテキストエディタ(TeraPad)に保存してあるので、毎回毎回コピペ⇒貼り付けでもいいのですが、その時間の短縮をしたいので【置換したあと置換前のデータに戻す方法】も知りたいと思っています。

もとからエクセル2007についている「元に戻す」ボタンが通用すればいいのですが、マクロやVBAを作動させた後では使えないみたいです。

n-junさん
もし元に戻すソースなどわかりましたら、どうかご教授ください。
よろしくおねがいします。

回答No.1

kybo

ちょっと手抜きプログラムですが、
ランダムで、前のものと同じにならない様にするには、以下の様にされてはどうでしょうか？

Sub test_Click()
For Each CellA In Range("A1:A5").Cells
Rnd1 = Int(Rnd() * 10) + 1
Do
Rnd2 = Int(Rnd() * 10) + 1
Loop Until Rnd1 <> Rnd2
Do
Rnd3 = Int(Rnd() * 10) + 1
Loop Until (Rnd1 <> Rnd3 And Rnd2 <> Rnd3)
Do
Rnd4 = Int(Rnd() * 10) + 1
Loop Until (Rnd1 <> Rnd4 And Rnd2 <> Rnd4 And Rnd3 <> Rnd4)
Do
Rnd5 = Int(Rnd() * 10) + 1
Loop Until (Rnd1 <> Rnd5 And Rnd2 <> Rnd5 And Rnd3 <> Rnd5 And Rnd4 <> Rnd5)
Do
Rnd6 = Int(Rnd() * 10) + 1
Loop Until (Rnd1 <> Rnd6 And Rnd2 <> Rnd6 And Rnd3 <> Rnd6 And Rnd4 <> Rnd6 And Rnd5 <> Rnd6)

CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd1, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd2, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd3, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd4, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd5, 2), , 1)
CellA.Value = Replace(CellA, "(置換する所)", Cells(Rnd6, 2), , 1)
Next
End Sub

お礼

kyboさん

ソースすごく参考になりました。
本当にありがとうございます。

エラーもなく見事うまくいきました。
私にはかなり使えるソースです。
感謝です。