-PR-
  • すぐに回答を!
  • 2011-01-21 06:16:37
  • 質問No.6463382
解決
済み

Excel2007VBAのランダム置換ソース

  • 閲覧数323
  • ありがとう数7
  • 気になる数0
  • 回答数7
  • コメント数0
azazazaz1023

お礼率 68% (13/19)

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

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


長くなりましたが、ここまでの条件を満たすVBAソースが知りたいです。
どうかよろしくおねがいいたします。
  • 回答数7
  • 気になる数0
  • みんなの回答(全7件)

    質問者が選んだベストアンサー

    • 2011-01-21 17:46:53
    • 回答No.4
    ki-aaa レベル11

    ベストアンサー率 49% (105/213)

    こんにちわ

    >※1回限定の置換ではなく、コマンドボタンを押すたびに(何度でも)ランダム置換できるようにしたいです。・・・とあるので、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
    お礼コメント
    azazazaz1023

    お礼率 68% (13/19)

    ki-aaaさん

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

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

    思わず何度もコマンドボタン押しちゃいました。
    すごく助かりました。
    感謝です。
    投稿日時 - 2011-01-22 02:39:08
    • ありがとう数0
    -PR-
    -PR-

    その他の回答 (全6件)

    • 2011-01-21 16:32:05
    • 回答No.2
    n-jun レベル14

    ベストアンサー率 33% (957/2864)

    知恵袋でも気になりましたけど。 >1回限定の置換ではなく、コマンドボタンを押すたびに(何度でも)ランダム置換できるようにしたいです。 の条件を満たすには、A列の文章を置換したあと元に戻すコードも必要って事ですか? 普通に作ると1回置換したら置換後の文章になりますよね? あるいはA列のデータをどこかにかコピペしても良いと言うこと? ...続きを読む
    知恵袋でも気になりましたけど。

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

    普通に作ると1回置換したら置換後の文章になりますよね?
    あるいはA列のデータをどこかにかコピペしても良いと言うこと?
    補足コメント
    azazazaz1023

    お礼率 68% (13/19)

    n-junさん

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

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

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

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

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

    n-junさん
    もし元に戻すソースなどわかりましたら、どうかご教授ください。
    よろしくおねがいします。
    投稿日時 - 2011-01-21 17:43:16
    • ありがとう数0
    • 2011-01-21 17:44:27
    • 回答No.3
    n-jun レベル14

    ベストアンサー率 33% (957/2864)

    No2です。 No2の内容は特に問題にならなければ。 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.C ...続きを読む
    No2です。

    No2の内容は特に問題にならなければ。

    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

    一例まで。
    お礼コメント
    azazazaz1023

    お礼率 68% (13/19)

    No.3(n-jun)さん

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

    今はまだ、教えていただいたソースをどう使ったらいいのか正直分かっていないのですが、感謝します。
    投稿日時 - 2011-01-22 02:23:30
    • ありがとう数0
    • 2011-01-21 18:37:34
    • 回答No.5
    n-jun レベル14

    ベストアンサー率 33% (957/2864)

    No3です。 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 = R ...続きを読む
    No3です。

    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 を実行するとエラーになるでしょう。。。
    お礼コメント
    azazazaz1023

    お礼率 68% (13/19)

    n-junさん

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

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

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

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

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

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


    そんなわけで、いろいろ恥しいことを書いてしまったのですが、
    いつか役に立つであろうソースを書いていただき、ありがとうございます。
    感謝です。
    投稿日時 - 2011-01-22 03:03:43
    • ありがとう数0
    • 2011-01-22 09:06:12
    • 回答No.7
    n-jun レベル14

    ベストアンサー率 33% (957/2864)

    No5です。 まずtry1とtry2用に2つのボタンを配置します。 try1 が Sub test_Click()~End Sub try2 が Sub reset_Click()~End Sub みたいしにして、それぞれに中のコードをコピペします。 あとは Sub test_Click() の上に Private vv As Variant Private ch As Boolean をコピ ...続きを読む
    No5です。

    まずtry1とtry2用に2つのボタンを配置します。

    try1 が Sub test_Click()~End Sub
    try2 が Sub reset_Click()~End Sub

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

    あとは Sub test_Click() の上に

    Private vv As Variant
    Private ch As Boolean

    をコピペしてみて下さい。
    お礼コメント
    azazazaz1023

    お礼率 68% (13/19)

    n-junさん

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

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

    でも、わざわざアドバイスくださり嬉しいです。
    感謝です。
    投稿日時 - 2011-01-22 20:30:24
    • ありがとう数0
    • 2011-01-21 18:44:08
    • 回答No.6
    Wendy02 レベル14

    ベストアンサー率 57% (3570/6233)

    B列が10000行あるということですから、高速化をさせるために、置換文字列数を数えて、B列から重複のない数字を抜き出します。 データを元に戻す用意もしました。 '// Sub TestReplace()  'Private Sub CommandButton1_Click()  Const sFND As String = "(" '置換対象の検索する ...続きを読む
    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
    お礼コメント
    azazazaz1023

    お礼率 68% (13/19)

    Wendy02さん

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

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

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

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

    Wendy02さん
    今回は貴重で入念なVBAソース、本当にありがとうございます。
    感謝です。
    投稿日時 - 2011-01-22 03:17:53
    • ありがとう数0
    • 2011-01-21 08:10:11
    • 回答No.1
    kybo レベル12

    ベストアンサー率 53% (344/640)

    ちょっと手抜きプログラムですが、 ランダムで、前のものと同じにならない様にするには、以下の様にされてはどうでしょうか? 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 < ...続きを読む
    ちょっと手抜きプログラムですが、
    ランダムで、前のものと同じにならない様にするには、以下の様にされてはどうでしょうか?

    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
    お礼コメント
    azazazaz1023

    お礼率 68% (13/19)

    kyboさん

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

    エラーもなく見事うまくいきました。
    私にはかなり使えるソースです。
    感謝です。
    投稿日時 - 2011-01-21 17:28:32
    • ありがとう数0
    • 回答数7
    • 気になる数0
    • ありがとう数1
    • ありがとう
    • なるほど、役に立ったなど
      感じた思いを「ありがとう」で
      伝えてください
    • 質問する
    • 専門家・企業を含めた、
      多くの人々が答えてくれます
    このやり方知ってる!同じこと困ったことある。経験を教えて!
    このQ&Aにはまだコメントがありません。
    あなたの思ったこと、知っていることをここにコメントしてみましょう。

    関連するQ&A

    -PR-
    -PR-

    その他の関連するQ&Aをキーワードで探す

    別のキーワードで再検索する
    -PR-
    -PR-
    -PR-

    特集


    -PR-

    ピックアップ

    -PR-
    ページ先頭へ