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

完全一致する単体の文字列のみ、別シートにある各行・各列指定のキーワードで置換したい
類似の質問もさせていただいていたのですが。
http://q.hatena.ne.jp/1522755461
http://q.hatena.ne.jp/1522512207

今回は「完全一致する場合」のみ、文字列を変えたいのです。
例えばSheet1のG列に、この質問 http://q.hatena.ne.jp/1522512207 の時と似たような状況で、

りんご
りんご ジョナゴールド
りんご ふじ
りんご 紅花




牛肉
牛肉 山形牛
牛肉 松坂牛



お米
お米 コシヒカリ
お米 ササニシキ



というデータが入ってるとします。
そしてSheet2で、「りんご」「牛肉」「お米」を各行に並べ、置換するためのキーワードを列に書き出し、実際に置換する方法を教えていただきました。

今回は「単体の文字列のみを置換」したいのです。
上記の例でいいますと「りんご」「牛肉」「お米」という、単体の文字列のみです。

●質問者: moon-fondu
●カテゴリ:コンピュータ 学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

質問者から

半角スペース込みの複合文字列(「りんご ジョナゴールド」「牛肉 山形牛」など)は無視しまして、単体の文字列のみを、Sheet2に書き出している指定の文字列に置換できる方法がもしありましたら。
ご教授いただけますと幸いです。

よろしくお願い致します。


1 ● Z1000S
●1000ポイント ベストアンサー

完全一致のセルが連続する場合のみを置換対象とするのであれば、
オートフィルタの指定を下記のように変更するだけで大丈夫です。

  'オートフィルタ実行
' .AutoFilter Field:=1, Criteria1:="=*" & sKeyword & "*"
 .AutoFilter Field:=1, Criteria1:=sKeyword

りんご
りんご ジョナゴールド
りんご ふじ
りんご 紅花

の先頭の「りんご」のような
完全一致のセルが単独で存在する場合も置換対象とするのであれば、
上記の変更に加え、置換処理部のIf、Else部を下記のようにコメント化、および修正して下さい。
(2018/04/24 09:00一部修正)

' '2行以上連続していたら置換
' If lEndRow > lBeginRow Then
 With wsTarget
  '置換
' .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Replace What:=sMainKeywords, Replacement:=sReplaceWords(lReplaceIndex), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False
 .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Value = sReplaceWords(lReplaceIndex)
 End With

 lTargetIndex = lTargetIndex + lTargetCount

 lReplaceIndex = lReplaceIndex + 1
' Else
' lTargetIndex = lTargetIndex + 1
' End If

moon-fonduさんのコメント
Z1000Sさん、ありがとうございます! いただきました修正箇所を、http://q.hatena.ne.jp/1522755461 でお教えいただきましたコードに貼り付けまして、再度マクロを実行してみました。 すると…「sReplaceWords」の部分でマクロが止まり、「コンパイルエラー SubまたはFunctionが定義されていません。」https://cdn-ak.f.st-hatena.com/images/fotolife/m/moon-fondu/20180425/20180425073829.jpg というエラーメッセージが出てきまして… もし原因と対処法がありましたらお教えいただけないでしょうか。 度々お手数お掛け致します、よろしくお願いします。

Z1000Sさんのコメント
画像を見て、まず気がついたのは、以下の3行がコメント化されていません。 そこをコメント化して、もう一度実行してみていただけますでしょうか。 それでもエラーとなるようであれば、お手数ですがもう一度 詳細な情報提供をお願いします。 >|vb| ' Else ' lTargetIndex = lTargetIndex + 1 ' End If ||< 現状のコード(上記3行がコメント化されていない状態)では、 VBEの画面で、メニューの「デバッグ」-「VBAProjectのコンパイル」をクリックすると、「コンパイルエラー」のメッセージが出るはずです。 これは、作成したコードに(構文上の)問題があるという事です。 今回の状況では、Ifに対するEnd Ifがない事が原因です。

moon-fonduさんのコメント
遅くなりましてすみません、コメント化しまして、もう1度実行してみました! http://f.hatena.ne.jp/moon-fondu/20180427232455 しかし…やはりエラーが出てきてしまい、マクロが止まってしまうようでして。 複合文字列ではない「りんご」単体のキーワードは、Sheet1のG列の5行目、7353行目、10301行目と、不規則に出てきまして。 これを、Sheet2のA列21行目の“りんご”から、右隣のB列以降のセル、「りんご 美味い」(C列)や「りんご 食べたい」(D列)、「りんご 買いたい」(E列)・・・というリストのキーワードに。 変えられたらと思いまして。 この例ですと、 Sheet1 G列5行目の“りんご”→りんご 美味い Sheet1 G列7353行目の“りんご”→りんご 食べたい Sheet1 G列10301行目の“りんご”→りんご 買いたい ・ ・ ・ といった文字列への置換が希望です。 詳細な情報提供になっておりますでしょうか、もしなっていないようでしたらお申し付けください。 お手隙の時に再度ご回答いただけますと幸いです。 よろしくお願い致します。

Z1000Sさんのコメント
1.コンパイルエラーは発生していませんか? >> VBEの画面で、メニューの「デバッグ」-「VBAProjectのコンパイル」をクリック << モジュールの先頭に >|vb| Option Explicit ||< と記載されいていないようであれば、この1行を追記して再度「VBAProjectのコンパイル」を実行してみて下さい。 もし、複数のモジュール(Module1、Module2・・・等)があるならば、すべてのモジュールの先頭に 「Option Explicit」を追記してからコンパイルしてみて下さい。 コンパイルエラーが発生するようであれば、表示されたメッセージに従って、コードを修正し、再度コンパイルしてエラーメッセージが表示されなくなるようにして下さい。 2.作成したプロシージャは、どのようにして実行していますか? 呼び出す際にプロシージャの綴が間違っていた場合にも、 「Sub または Functionが定義されていません」と表示されます。 コンパイルエラーが発生しないのに、このメッセージが表示される場合には、これの可能性を否定できません。 3.エラーメッセージが表示されるタイミングは? ・プロシージャ呼び出し時(置換処理が全く行われていない) ・プロシージャ実行中(何件かの置換処理が行われた後) プロシージャ実行中に発生している場合、コード中に反転表示されている箇所はありますか?ある場合、それはコードのどの部分ですか? まずは、以上の点について確認をお願いします。

moon-fonduさんのコメント
対処法ありがとうございます、ためしてみました! まずモジュールの先頭に「Option Explicit」を入れるというのは、 http://q.hatena.ne.jp/1522512207 に記載いただいたマクロの冒頭に入れるということでよろしいでしょうか? ですので、 ---------------- Option Explicit '置換対象データ関連 Private Const TARGET_SHEET_NAME As String = "Sheet1" ・ ・ ・ ---------------- で実行してみました。 すると同様のエラーがやはり出てきてしまいます。 実行方法につきましては、マクロを貼り付けた後、一回バッテンを押して閉じまして。 Excelの開発タブから「マクロ」をクリックし、「replaceCellsMain」を選んで実行しています。 反転表示されている箇所は、「Sub または Functionが定義されていません」というメッセージとともにマクロが止まる?「sReplaceWords」の箇所かと思います。 また、全体を見たら気付いたのですが、「sReplaceWords」の少し上にあります、 「Private Sub replaceCells(ByRef wsTarget As Worksheet, ByRef lTargetRows() As Long, ByRef ReplaceInfo As ReplaceInformation)」 の部分が黄色くなっていました。 http://f.hatena.ne.jp/moon-fondu/20180428102155

moon-fonduさんのコメント
エラーメッセージが表示されるタイミングは、おそらく「プロシージャ呼び出し時(置換処理が全く行われていない)」でしょうか…Sheet1を見ると何も置換されていないので。 しかし「sReplaceWords」で止まるので、そこまではプログラムが走っているということでしょうか、実行はできているということかもしれません…。

Z1000Sさんのコメント
とりあえず、コンパイルエラーの出ないソース。 こちらで、動かした範囲では「Sub または Functionが定義されていません」は表示されません。 >|vb| Option Explicit '置換対象データ関連 Private Const TARGET_SHEET_NAME As String = "Sheet1" 'フィルターの基準となる列(G列) Private Const TARGET_COL As Long = 7 'キーワード関連 Private Const KEYWORDS_SHEET_NAME As String = "Sheet2" Private Const KEYWORDS_BEGIN_ROW As Long = 2 Private Const MAIN_KEYWORDS_COL As Long = 1 Private Const REPLACE_WORDS_BEGIN_COL As Long = 2 Private Const REPLACE_WORDS_COUNT As Long = 10 Public Sub replaceCellsMain() Dim wsKeywords As Worksheet Dim wsTarget As Worksheet Dim lKeywordsCount As Long Dim sReplaceWords(REPLACE_WORDS_COUNT - 1) As String Dim sMainKeywords As String Dim lTargetRows() As Long Dim lTargetRowsCount As Long Dim i As Long Application.ScreenUpdating = False Set wsTarget = ThisWorkbook.Worksheets(TARGET_SHEET_NAME) Set wsKeywords = ThisWorkbook.Worksheets(KEYWORDS_SHEET_NAME) '置換するキーワード数取得 lKeywordsCount = getKeywordsCount(wsKeywords) For i = 0 To lKeywordsCount - 1 '置換するキーワードと置換後の文字列取得 sMainKeywords = getKeywords(wsKeywords, i, sReplaceWords) 'キーワードが含まれる行を格納する配列の初期化 ReDim lTargetRow(0) 'キーワードが含まれる行の取得 lTargetRowsCount = getTargetRows(wsTarget, sMainKeywords, lTargetRows) If lTargetRowsCount > 0 Then '置換 Call replaceCells(wsTarget, sMainKeywords, lTargetRows, sReplaceWords) End If Debug.Print sMainKeywords & " Done." Next i Set wsKeywords = Nothing Set wsTarget = Nothing Application.ScreenUpdating = True End Sub Private Function getKeywordsCount(ByRef ws As Worksheet) As Long Dim lEndRow As Long lEndRow = ws.Cells(ws.Rows.Count, MAIN_KEYWORDS_COL).End(xlUp).Row getKeywordsCount = lEndRow - KEYWORDS_BEGIN_ROW + 1 End Function Private Function getKeywords(ByRef ws As Worksheet, ByVal lIndex As Long, ByRef sKeywords() As String) As String Dim i As Long For i = 0 To REPLACE_WORDS_COUNT - 1 sKeywords(i) = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL + i).Value Next i getKeywords = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, MAIN_KEYWORDS_COL).Value End Function Private Function getTargetRows(ByRef ws As Worksheet, ByVal sKeyword As String, ByRef lTargetRows() As Long) As Long Dim xlFilterRow As Range Dim lHeaderRow As Long Dim lEndRow As Long Dim lTargetCounts As Long Dim lCount As Long With ws 'オートフィルタの設定状態 If .AutoFilterMode = True Then 'オートフィルタが設定済みなら、一旦解除 .AutoFilter.Range.AutoFilter End If 'オートフィルタのヘッダとなるダミー行を挿入 .Rows(1).Insert lHeaderRow = 1 .Cells(lHeaderRow, TARGET_COL).Value = "DummyHeader" '終了行 lEndRow = .Cells(.Rows.Count, TARGET_COL).End(xlUp).Row '指定文字データを抽出 With .Range(.Cells(1, TARGET_COL), .Cells(lEndRow, TARGET_COL)) 'オートフィルタ実行 ' .AutoFilter Field:=1, Criteria1:="=*" & sKeyword & "*" .AutoFilter Field:=1, Criteria1:=sKeyword '絞り込まれた件数取得(ヘッダー行が含まれているため補正) lTargetCounts = .SpecialCells(xlCellTypeVisible).Count - lHeaderRow If lTargetCounts > 0 Then '対象の行を格納する配列初期化 ReDim lTargetRows(lTargetCounts - 1) For Each xlFilterRow In .SpecialCells(xlVisible) '対象データの行の取得 If xlFilterRow.Row > lHeaderRow Then 'ヘッダー行以降 lTargetRows(lCount) = xlFilterRow.Row - lHeaderRow lCount = lCount + 1 End If Next xlFilterRow End If End With 'オートフィルタ解除 .AutoFilter.Range.AutoFilter 'ダミーヘッダー行削除 .Rows(1).Delete End With getTargetRows = lTargetCounts End Function Private Sub replaceCells(ByRef wsTarget As Worksheet, ByVal sMainKeywords As String, ByRef lTargetRows() As Long, ByRef sReplaceWords() As String) Dim lBeginRow As Long Dim lEndRow As Long Dim lTargetIndex As Long Dim lTargetCount As Long Dim lReplaceIndex As Long Dim i As Long lTargetIndex = 0 lReplaceIndex = 0 Do Until (lTargetIndex > UBound(lTargetRows)) Or (lReplaceIndex > UBound(sReplaceWords)) lBeginRow = lTargetRows(lTargetIndex) lEndRow = lBeginRow lTargetCount = 1 '値の連続した最終行を取得 For i = 1 To UBound(lTargetRows) - lTargetIndex If lTargetRows(lTargetIndex + i) = lEndRow + 1 Then lEndRow = lEndRow + 1 lTargetCount = lTargetCount + 1 Else Exit For End If Next i ' '2行以上連続していたら置換 ' If lEndRow > lBeginRow Then With wsTarget '置換 ' .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Replace What:=sMainKeywords, Replacement:=sReplaceWords(lReplaceIndex), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Value = sReplaceWords(lReplaceIndex) End With lTargetIndex = lTargetIndex + lTargetCount lReplaceIndex = lReplaceIndex + 1 ' Else ' lTargetIndex = lTargetIndex + 1 ' End If Loop End Sub ||<

moon-fonduさんのコメント
Z1000Sさんありがとうございます、遅くなりましてすみません。 今度はうまく稼働し、置換されました(^^; ありがとうございます。 ただすみません、Sheet2に書き出している、置換したい文字列なのですが。 K列までは問題なく置換されていくのですが、L列より右側の文字列はなぜか、置換対象にならず、 Sheet1の方で置換しきれないデータがいくつポツポツと残りまして。 この時 http://q.hatena.ne.jp/1522755461 と同じく、Sheet2記載の置換したいキーワードは、 各行バラバラになっております。 (例えるなら、「りんご」はDC列までびっしり置換したいキーワードが並び、「牛肉」はAB列まで、 「お米」はBD列まで、と並んでいる状況です。) Sheet2・A列に記載している置換対象のキーワード、及びB列以降にずらりと右へ(行方向へ)記載しております置換したいキーワードにつきまして。 置換したいキーワードが無くなる端までは、空白セルも無くキーワードを並べておりますので。 「空白セルが出てくる手前」まで、Sheet2の各行に並ぶキーワードで、Sheet1の単体の文字列を 置換できないでしょうか。 度々お手数お掛けしてしまい恐縮です、もし可能でしたらよろしくお願い致します<m(__)m>

Z1000Sさんのコメント
勘違いして、先の10個固定版を元にしていました。 申し訳ないです。 これでどうでしょうか >|vb| Option Explicit '置換対象データ関連 Private Const TARGET_SHEET_NAME As String = "Sheet1" 'フィルターの基準となる列(G列) Private Const TARGET_COL As Long = 7 'キーワード関連 Private Const KEYWORDS_SHEET_NAME As String = "Sheet2" Private Const KEYWORDS_BEGIN_ROW As Long = 2 Private Const MAIN_KEYWORDS_COL As Long = 1 Private Const REPLACE_WORDS_BEGIN_COL As Long = 2 Private Type ReplaceInformation sKeyword As String lCount As Long sReplaceWords() As String End Type Public Sub replaceCellsMain() Dim wsKeywords As Worksheet Dim wsTarget As Worksheet Dim lKeywordsCount As Long Dim ReplaceInfo As ReplaceInformation Dim lTargetRows() As Long Dim lTargetRowsCount As Long Dim i As Long Application.ScreenUpdating = False Set wsTarget = ThisWorkbook.Worksheets(TARGET_SHEET_NAME) Set wsKeywords = ThisWorkbook.Worksheets(KEYWORDS_SHEET_NAME) '置換するキーワード数取得 lKeywordsCount = getKeywordsCount(wsKeywords) For i = 0 To lKeywordsCount - 1 '置換するキーワードと置換後の文字列取得 Call getKeywords(wsKeywords, i, ReplaceInfo) 'キーワードが含まれる行を格納する配列の初期化 ReDim lTargetRow(0) 'キーワードが含まれる行の取得 lTargetRowsCount = getTargetRows(wsTarget, ReplaceInfo.sKeyword, lTargetRows) If lTargetRowsCount > 0 Then '置換 Call replaceCells(wsTarget, lTargetRows, ReplaceInfo) End If Debug.Print ReplaceInfo.sKeyword & " Done." Next i Set wsKeywords = Nothing Set wsTarget = Nothing Application.ScreenUpdating = True End Sub Private Function getKeywordsCount(ByRef ws As Worksheet) As Long Dim lEndRow As Long lEndRow = ws.Cells(ws.Rows.Count, MAIN_KEYWORDS_COL).End(xlUp).Row getKeywordsCount = lEndRow - KEYWORDS_BEGIN_ROW + 1 End Function Private Sub getKeywords(ByRef ws As Worksheet, ByVal lIndex As Long, ByRef ReplaceInfo As ReplaceInformation) Dim sReplaceWord As String ReplaceInfo.sKeyword = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, MAIN_KEYWORDS_COL).Value ReplaceInfo.lCount = 0 ReDim ReplaceInfo.sReplaceWords(0) sReplaceWord = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL).Value Do Until sReplaceWord = "" ReDim Preserve ReplaceInfo.sReplaceWords(ReplaceInfo.lCount) ReplaceInfo.sReplaceWords(ReplaceInfo.lCount) = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL + ReplaceInfo.lCount).Value ReplaceInfo.lCount = ReplaceInfo.lCount + 1 sReplaceWord = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL + ReplaceInfo.lCount).Value Loop End Sub Private Function getTargetRows(ByRef ws As Worksheet, ByVal sKeyword As String, ByRef lTargetRows() As Long) As Long Dim xlFilterRow As Range Dim lHeaderRow As Long Dim lEndRow As Long Dim lTargetCounts As Long Dim lCount As Long With ws 'オートフィルタの設定状態 If .AutoFilterMode = True Then 'オートフィルタが設定済みなら、一旦解除 .AutoFilter.Range.AutoFilter End If 'オートフィルタのヘッダとなるダミー行を挿入 .Rows(1).Insert lHeaderRow = 1 .Cells(lHeaderRow, TARGET_COL).Value = "DummyHeader" '終了行 lEndRow = .Cells(.Rows.Count, TARGET_COL).End(xlUp).Row '指定文字データを抽出 With .Range(.Cells(1, TARGET_COL), .Cells(lEndRow, TARGET_COL)) 'オートフィルタ実行 ' .AutoFilter Field:=1, Criteria1:="=*" & sKeyword & "*" .AutoFilter Field:=1, Criteria1:=sKeyword '絞り込まれた件数取得(ヘッダー行が含まれているため補正) lTargetCounts = .SpecialCells(xlCellTypeVisible).Count - lHeaderRow If lTargetCounts > 0 Then '対象の行を格納する配列初期化 ReDim lTargetRows(lTargetCounts - 1) For Each xlFilterRow In .SpecialCells(xlVisible) '対象データの行の取得 If xlFilterRow.Row > lHeaderRow Then 'ヘッダー行以降 lTargetRows(lCount) = xlFilterRow.Row - lHeaderRow lCount = lCount + 1 End If Next xlFilterRow End If End With 'オートフィルタ解除 .AutoFilter.Range.AutoFilter 'ダミーヘッダー行削除 .Rows(1).Delete End With getTargetRows = lTargetCounts End Function Private Sub replaceCells(ByRef wsTarget As Worksheet, ByRef lTargetRows() As Long, ByRef ReplaceInfo As ReplaceInformation) Dim lBeginRow As Long Dim lEndRow As Long Dim lTargetIndex As Long Dim lTargetCount As Long Dim lReplaceIndex As Long Dim i As Long lTargetIndex = 0 lReplaceIndex = 0 Do Until (lTargetIndex > UBound(lTargetRows)) Or (lReplaceIndex > ReplaceInfo.lCount - 1) lBeginRow = lTargetRows(lTargetIndex) lEndRow = lBeginRow lTargetCount = 1 '値の連続した最終行を取得 For i = 1 To UBound(lTargetRows) - lTargetIndex If lTargetRows(lTargetIndex + i) = lEndRow + 1 Then lEndRow = lEndRow + 1 lTargetCount = lTargetCount + 1 Else Exit For End If Next i ' '2行以上連続していたら置換 ' If lEndRow > lBeginRow Then With wsTarget '置換 ' .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Replace What:=ReplaceInfo.sKeyword, Replacement:=ReplaceInfo.sReplaceWords(lReplaceIndex), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Value = ReplaceInfo.sReplaceWords(lReplaceIndex) End With lTargetIndex = lTargetIndex + lTargetCount lReplaceIndex = lReplaceIndex + 1 ' Else ' lTargetIndex = lTargetIndex + 1 ' End If Loop End Sub ||<

moon-fonduさんのコメント
遅くなりまして、すみません(;'∀') ありがとうございます、うまく置換できました! 助かりました(^^;
関連質問

●質問をもっと探す●



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