- 締切済み
Excel 文字列を検索して全て置換するマクロ
当方VBA初心者なのですが、ExcelのVBAで作ったマクロでうまく動かなくて困っています。 もしおわかりになる方がいらっしゃったら是非よろしくお願いいたします。 *実現したいこと '”reference”という名前のシートに、次のようなデータが入っています。 (1) りんご (2) みかん (3) キウイ ・・・ これを、配列を2つ用意し、 (1)を配列Listに、(2)を配列List2へ格納して行きます。 '"data"という名前のシートには、A列の1~10行目までに文章が入っていて、 "家には、(1)があります。" "冬になるとよく(2)を食べます。" ・・・・ この全文をcというRangeに設定し、そのcの中において、 もし、配列1((1)等)のキーワードがあったら、 'そのキーワードを配列2(りんご等)の内容に書き換える。 'キーワードは、データシートに複数回出てくる場合もある。 *困っていること 下記のマクロだと、一度目のObjFindまでは成功するのですが、 List(i)を探しているはずが、2回目から、その変更後の文字列が含まれた全文を検索するようになってしまいます。 以下マクロです。 よろしくお願いいたします。 Sub TEST() Dim List() As String, List2() As String 'List Dim i As Integer Dim iRow As Integer iRow = Worksheets("reference").Cells(Rows.Count, 1).End(xlUp).Row ReDim List(iRow) ReDim List2(iRow) For i = 1 To iRow List(i) = Worksheets("reference").Cells(i, 1).Value List2(i) = Worksheets("reference").Cells(i, 2).Value Next i Dim lngYLine As Long Dim intXLine As Integer Dim objFind As Object Dim strAddress As String Dim strSamp As String Dim objRange As Range Dim c As Range For i = 1 To iRow Set objRange = Worksheets("data").Range("A1:A331") Set objFind = objRange.Cells.Find(List(i)) If Not objFind Is Nothing Then For Each c In objRange If c.Value = objFind Then lngYLine = objFind.Cells.Row intXLine = objFind.Cells.Column strSamp = Worksheets("data").Cells(lngYLine, 1) strSamp = Replace(strSamp, List(i), List2(i)) Worksheets("data").Cells(lngYLine, 1) = strSamp MsgBox List(i) + "は" + List2(i) + "に変更されました" Set objFind = Cells.FindNext(objFind) End If Next c Else MsgBox List(i) + "は見つかりませんでした" End If Next i End Sub
- みんなの回答 (5)
- 専門家の回答
みんなの回答
- oka_me
- ベストアンサー率86% (26/30)
#1です。 >このコードについてですが、あらかじめ配列に格納してということではなくて、 >その場で、A列とB列を読み込んで、セルを全て参照し、変更するべきものがあったら置換するという解釈であっていますでしょうか。 その認識で合っています。 (1列目から順番に) 変数w1にA列の値、w2にB列の値をそれぞれ格納 ↓ w1を検索(Find使用) ↓ 見つかった場合w2へ置換(Replace使用)の後変更されましたとMsgbox表示 見つからない場合は見つかりませんでしたとMsgbox表示のみ ↓ 次の行に移動しw1、w2の値を再設定(以下referenceの行数分繰り返し) のような流れになります。 #2の方も書かれていますが、やはりReplaceを使用した方が少ないステップで済むので 後で混乱してしまうような可能性も低いかと思います。。。 最後に追伸ですが申し訳ありません、前回#1の回答の前半部分はやはり再検証した結果何点かまだ不具合が発生してしまいましたので、その部分はスルーしてください。。m(_ _)m (回答の編集や削除が出来ないのはやはり不便ですね 苦笑)
- cj_mover
- ベストアンサー率76% (292/381)
#2、cjです。 単に置換するということで、必要ないものを削って、シンプルに書き直してみました。 List配列については、配列変数の代りに、Cells 配列で直接取得します。 見つからない場合の判別をする為には、.Find メソッドは省けません。 .Find メソッドで指定が済んだ引数(LookAt)は、 .Replace メソッドについては引数を省略できます。 一度しか使わない値については、変数を使わず直値にしています。 referenceシートへの参照は、With フレーズでブロック化しています。 リスト範囲に空セルはない、という前提が確実なら、◆の2行は不要です。 ' ' ================================= Sub Re8293972a() Dim objRange As Range Dim i As Long Set objRange = Worksheets("data").Range("A1:A331") With Worksheets("reference") For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row If .Cells(i, 1) <> "" Then ' ◆ If objRange.Find(What:=.Cells(i, 1), LookIn:=xlValues, LookAt:=xlPart) Is Nothing Then MsgBox """" & .Cells(i, 1) & """ は見つかりませんでした" Else objRange.Replace What:=.Cells(i, 1), Replacement:=.Cells(i, 2) MsgBox """" & .Cells(i, 1) & """ は """ & .Cells(i, 2) & """ に変更されました" End If End If ' ◆ Next i End With Set objRange = Nothing End Sub ' ' ================================= メッセージボックスの表示が不要になったり、 リスト範囲に空セルはない、という前提が確実なら、 もっとずっとシンプルに ' ' ================================= Sub Re8293972b() Dim objRange As Range Dim i As Long Set objRange = Worksheets("data").Range("A1:A331") With Worksheets("reference") For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row objRange.Replace What:=.Cells(i, 1), Replacement:=.Cells(i, 2), LookAt:=xlPart Next i End With Set objRange = Nothing End Sub ' ' ================================= みたいになります。 以上です。
- tom04
- ベストアンサー率49% (2537/5117)
こんばんは! 横からお邪魔します。 こういうコトでしょうかね? ↓の画像で上側が「data」Sheet、下側が「reference」Sheetとします。 元々画像の「data」SheetのA列がC列のようになっていて マクロ実行後はA列のように「置換」したい!という解釈での一例です。 Sub Sample1() Dim i As Long, k As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("data") Set wS2 = Worksheets("reference") Application.ScreenUpdating = False For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row For k = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If InStr(wS1.Cells(i, "A"), wS2.Cells(k, "A")) > 0 Then wS1.Cells(i, "A") = Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A"), wS2.Cells(k, "B")) End If Next k Next i Application.ScreenUpdating = True End Sub ※ メッセージボックスはその都度マクロが止まってしまうので、敢えて表示させていません。 ※ 的外れならごめんなさいね。m(_ _)m
- cj_mover
- ベストアンサー率76% (292/381)
こんにちは。 やりたいこと、が、いまひとつ解らないのですが、 こんなことをやりたいのかな?、というマクロを例として挙げてみます。 通常、置換に関しては、 .Replace メソッドを用いてセル範囲に対して[すべて置換]するか、 セル範囲すべてをループして、セルひとつずつの.Valueを変更していくか、 主に2つの方法があります。 特別な条件がないなら、検索する文字列ごとに[すべて置換]すればいいように思います。 .Find メソッドを使うなら、.Replace メソッドで置換するのが自然で、統一感もあります。 何か理由があってセルひとつずつをループするのでしょうか? この理由が、判らないので、どう答えていいか迷いましたが、 一例として、 置換したセル範囲の.Addressを添えて、「何処の何を何に換えたか」 を表示するように書いてみました。 これなら、セルひとつずつループしたかった理由も説明できるかな?と思いましたので。 ただ、置換に関してはやはり、.Replace メソッドを用いて一括する方が速くて効率的ですし、 置換したセル範囲の.Addressを採るのも、 .Find メソッド、.FindNext メソッドで抽出されたセルだけを相手にする方が無駄が無いですから、 そのように書いています。 もっとも、沢山の書き方がある中での一例ですから、 .Find メソッド、.Replace メソッド、どちらも使わなくても、 同様の処理は可能なのですが、 そこら辺は要求仕様がもう少しハッキリしてから、必要性があれば、また考えてみるかも知れません。 取り敢えず、試してみて、実行結果と、求める結果、との間に、どんな違いがあるのか、 補足でも貰えれば、今よりはこちらの理解も進むと思いますので。 ' ' ============ 標準モジュール ============ Sub Re8293972() Dim objRange As Range Dim objFind As Range Dim mtxTable As Variant Dim strAddress As String Dim iRow As Integer Dim n1stRow As Integer Dim i As Integer With Worksheets("reference") iRow = .Cells(Rows.Count, 1).End(xlUp).Row mtxTable = .Range("A1:B" & iRow).Value End With Set objRange = Worksheets("data").Range("A1:A331") For i = 1 To iRow If mtxTable(i, 1) <> "" Then strAddress = "" Set objFind = objRange.Find(What:=mtxTable(i, 1), After:=objRange(objRange.Count), _ LookIn:=xlValues, LookAt:=xlPart, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, MatchByte:=False) If Not objFind Is Nothing Then n1stRow = objFind.Row Do strAddress = strAddress & "," & objFind.Address(0, 0) Set objFind = objRange.FindNext(objFind) If objFind Is Nothing Then Exit Do Loop While objFind.Row > n1stRow objRange.Replace What:=mtxTable(i, 1), Replacement:=mtxTable(i, 2) MsgBox Mid(strAddress, 2) & vbLf & """" & mtxTable(i, 1) & """ は """ & mtxTable(i, 2) & """ に変更されました" Else MsgBox mtxTable(i, 1) & " は見つかりませんでした" End If End If Next i End Sub ' ' =================================
- oka_me
- ベストアンサー率86% (26/30)
>一度目のObjFindまでは成功するのですが、 >List(i)を探しているはずが、2回目から、その変更後の文字列が含まれた全文を検索するようになってしまいます。 という現象がよく分からなかったのですが(こちらで同様の検証をしたところ、2回目以降はエラーで止まってしまいました)、例えば質問文内のFor Each c In objRange~Next cの箇所を If Not objFind Is Nothing Then If c.Value = objFind.Value Then lngYLine = objFind.Cells.Row intXLine = objFind.Cells.Column strSamp = Worksheets("data").Cells(lngYLine, 1) strSamp = Replace(strSamp, List(i), List2(i)) Worksheets("data").Cells(lngYLine, 1) = strSamp MsgBox List(i) + "は" + List2(i) + "に変更されました" End If Set objFind = Cells.FindNext(objFind) End If (※If Not objFind Is Nothing Then の記述を2回使用することになります。2回目の記述は1件目が見つかって置換された際の次回以降の分岐になります) としてみても解決しないでしょうか? また余談ですが、私自身も以前質問者様と似たような処理を行うマクロを作成したことがあるので、 その時のコードを少し修正してみました。 Sub test2() Dim h As Long Dim i As Long Dim w1 As Variant Dim w2 As Variant Dim c As Range h = Sheets("reference").Range("A" & Rows.Count).End(xlUp).Row Set objRange = Sheets("data").Range("A1:A331") For i = 1 To h w1 = Sheets("reference").Range("A" & i).Value w2 = Sheets("reference").Range("B" & i).Value Set c = objRange.Cells.Find(what:=w1, lookat:=xlPart) If Not c Is Nothing Then objRange.Cells.Replace what:=w1, Replacement:=w2, lookat:=xlPart MsgBox w1 + "は" + w2 + "に変更されました" Else MsgBox w1 + "は見つかりませんでした" End If Set c = Nothing Next End Sub 上記でも似たような処理が可能かと思います(見当違いでしたらすみません)
補足
ご回答いただきましてありがとうございます。m(_ _)m 後半にご記載いただいたマクロで動かしてみましたら、 理想に近い動き方をしていました! 明日、改めて本物のデータで確認してみたいと思います。 このコードについてですが、あらかじめ配列に格納してということではなくて、 その場で、A列とB列を読み込んで、セルを全て参照し、変更するべきものがあったら置換するという解釈であっていますでしょうか。 よろしくお願いいたします。
補足
ご回答いただきありがとうございます。m(_ _)m 要求条件が明確でなくてすいません、 当方がやりたいことは、 dataシートの中に入っているセル全てに検索をかけて、 (1)をみつけたら、”りんご”と全てを置換するということです。 ご提示いただいた、2つの方法のうち、 ・.Replace メソッドを用いてセル範囲に対して[すべて置換]するか、 ・セル範囲すべてをループして、セルひとつずつの.Valueを変更していくか、 私自体が、後者しか方法を知らなかったため、最初から最後までをループして探し出してみていくような形でかいていました。 Range("A1:A331").Replace What:=List(i), Replacement:=List2(i), LookAt:=xlPart, MatchCase:=True というような形で記載になりますでしょうか。。 そして、マクロのご提示ありがとうございます。 動かしてみます。