Excel リストと一致する部分を削除してコピー

質問

エクセル2010の利用方法について質問させてください。

sheet1 A列のデータをsheet1 B列にコピーします。
その際に、sheet2 A列に作成したリストを参照して
sheet1 A列のデータとsheet2 A列に一致する文字列があった場合、
sheet1 A列のデータから一致する部分を取り除いてsheet1 B列に表示させたいのです。

例）
■sheet1 A列
1 腐ったミカン
2 りんご畑
3 大きな梨が食べたいな
　：

■sheet2 A列
1 が食べたいな
2 腐った
3 大きな
4 畑
　：

■sheet1 B列
1 ミカン
2 りんご
3 梨
　：

データとリストが膨大(今後も随時追加予定)で、自動化することができればと考えております。
どうぞよろしくお願いいたします。

回答No.3

kagakusuki · ベストアンサー

回答No.2です。
　先程のVBAよりもこちらの方が処理速度が速いかも知れません。

Sub QNo8955469_Excel_リストと一致する部分を削除してコピー改()

Dim DelStrSheet, DelStrFCell, OriDataSheet, OriDataFCell, PasteColumn, TempStr, myinfo As String
Dim r, DelStrRange, OriDataRange As Range
Dim DelStrRB, OriDataRB, OffsetC, myMsg As Long

OriDataSheet = "Sheet14" '元データが入力されているシート
OriDataFCell = "A1" '元データが入力されているセルの中で一番上にあるセル
PasteColumn = "B" '元データから削除対象となる文字列を取り除いたデータを貼り付ける列
DelStrSheet = "Sheet14 (2)" '削除対象となる文字列のリストのシート
DelStrFCell = "A1" '削除対象となる文字列が入力されているセルの中で一番上にあるセル

'元データ列と貼り付け先の列番号の差
OffsetC = Columns(PasteColumn).Column - Range(OriDataFCell).Column

myinfo = ""
If IsError(Evaluate("ROW('" & OriDataSheet & "'!A1)")) Then _
myinfo = "元データが入力されているシート" & Chr(13) & Chr(13) & OriDataSheet
If IsError(Evaluate("ROW('" & DelStrSheet & "'!A1)")) Then
If myinfo <> "" Then myinfo = myinfo & Chr(13) & "及び" & Chr(13) & Chr(13)
myinfo = myinfo & "元データから削除する文字列のリストが入力されているシート" _
& Chr(13) & Chr(13) & DelStrSheet
End If
If myinfo <> "" Then
MsgBox myinfo & Chr(13) & Chr(13) & "が見つかりません。" & Chr(13) & _
"マクロの実行を中止します。", vbExclamation, "存在しないシート"
Exit Sub
End If

With Sheets(OriDataSheet).Range(OriDataFCell)
'元データが入力されている一番下の行
OriDataRB = Sheets(OriDataSheet).Cells(Rows.Count, .Column).End(xlUp).Row
If OriDataRB > .Row Then GoTo label1
If OriDataRB <> .Row Or .Value <> "" Then GoTo label1
MsgBox "処理すべき元データが見つかりません。" & Chr(13) & _
"マクロの実行を中止します。", vbInformation, "データ無し"
Exit Sub
label1:
Set OriDataRange = .Resize(OriDataRB - .Row + 1, 1)
End With

With Sheets(DelStrSheet).Range(DelStrFCell)
'削除対象となる文字列が入力されている一番下の行
DelStrRB = Sheets(DelStrSheet).Cells(Rows.Count, .Column).End(xlUp).Row
If DelStrRB > .Row Then GoTo label2
If DelStrRB <> .Row Or .Value <> "" Then GoTo label2
MsgBox "元データから削除する文字列のリストが見つかりません。" & Chr(13) & _
"マクロの実行を中止します。", vbInformation, "データ無し"
Exit Sub
label2:
Set DelStrRange = .Resize(DelStrRB - .Row + 1, 1)
End With

myMsg = MsgBox("このマクロを実行しますと" & OriDataSheet & "の" & PasteColumn _
& "列のデータが上書きされます。" & Chr(13) & "マクロを実行しますか？" & Chr(13) _
& Chr(13) & "[OK]：マクロを実行します" & Chr(13) & "[キャンセル]：マクロを終了します" _
, vbOKCancel + vbQuestion, "確認")
If myMsg = vbCancel Then Exit Sub

Sheets(OriDataSheet).Range(PasteColumn & Range(OriDataFCell).Row & ":" & _
PasteColumn & Range(PasteColumn & Rows.Count).End(xlUp).Row).ClearContents
OriDataRange.Offset(0, OffsetC).Value = OriDataRange.Value
For Each r In DelStrRange
OriDataRange.Offset(0, OffsetC).Replace What:=r.Value, Replacement:="", LookAt:=xlPart
Next r

End Sub

お礼

理想通りの処理が行えました。
処理前に確認までしていただけるなんて、、感動です！
丁寧に作成していただきありがとうございました。
私もkagakusuki様を目指して勉強したいと思います。

回答No.2

kagakusuki

sheet2 A列に入力されている取り除かねばならない文字列が64個まででしたら関数を使って除去する事も出来なくはないのですが、

>データとリストが膨大(今後も随時追加予定)

という事情がお有りでは、その内、取り除かねばならない文字列が64個以上になって、関数だけでは対応出来なくなるという恐れがあると考えた方が良いかも知れません。
　又、Sheet1やSheet2とは別のシート上に作業列を何列も設けて、関数だけでは処理できない中間的な処理を、別の列において行わせておく事で、文字列が64個以上になった場合に対応するという方法も無くは無いのですが、取り除かねばならない文字列が100個、200個と増えて行くのに従って、作業列も2列3列と増やしていかねばならず、作業列のセルに格納しなければならないデータの分だけ、データの総量が2倍3倍と増えてしまう事になりますので、「膨大(今後も随時追加予定)」と仰る度データが多いのでしたら、あまり好ましい方法とは申せません。

　その様な訳で、VBAを用いて処理を行わせた方が宜しいのではないかと思います。

Sub QNo8955469_Excel_リストと一致する部分を削除してコピー()

Dim DelStrSheet, DelStrFCell, OriDataSheet, OriDataFCell, PasteColumn, TempStr, myinfo As String
Dim r1, r2, DelStrRange, OriDataRange As Range
Dim DelStrRB, OriDataRB, OffsetC, myMsg As Long

OriDataSheet = "Sheet14" '元データが入力されているシート
OriDataFCell = "A1" '元データが入力されているセルの中で一番上にあるセル
PasteColumn = "B" '元データから削除対象となる文字列を取り除いたデータを貼り付ける列
DelStrSheet = "Sheet14 (2)" '削除対象となる文字列のリストのシート
DelStrFCell = "A1" '削除対象となる文字列が入力されているセルの中で一番上にあるセル

'元データ列と貼り付け先の列番号の差
OffsetC = Columns(PasteColumn).Column - Range(OriDataFCell).Column

myinfo = ""
If IsError(Evaluate("ROW('" & OriDataSheet & "'!A1)")) Then _
myinfo = "元データが入力されているシート" & Chr(13) & Chr(13) & OriDataSheet
If IsError(Evaluate("ROW('" & DelStrSheet & "'!A1)")) Then
If myinfo <> "" Then myinfo = myinfo & Chr(13) & "及び" & Chr(13) & Chr(13)
myinfo = myinfo & "元データから削除する文字列のリストが入力されているシート" _
& Chr(13) & Chr(13) & DelStrSheet
End If
If myinfo <> "" Then
MsgBox myinfo & Chr(13) & Chr(13) & "が見つかりません。" & Chr(13) & _
"マクロの実行を中止します。", vbExclamation, "存在しないシート"
Exit Sub
End If

With Sheets(OriDataSheet).Range(OriDataFCell)
'元データが入力されている一番下の行
OriDataRB = Sheets(OriDataSheet).Cells(Rows.Count, .Column).End(xlUp).Row
If OriDataRB > .Row Then GoTo label1
If OriDataRB <> .Row Or .Value <> "" Then GoTo label1
MsgBox "処理すべき元データが見つかりません。" & Chr(13) & _
"マクロの実行を中止します。", vbInformation, "データ無し"
Exit Sub
label1:
Set OriDataRange = .Resize(OriDataRB - .Row + 1, 1)
End With

With Sheets(DelStrSheet).Range(DelStrFCell)
'削除対象となる文字列が入力されている一番下の行
DelStrRB = Sheets(DelStrSheet).Cells(Rows.Count, .Column).End(xlUp).Row
If DelStrRB > .Row Then GoTo label2
If DelStrRB <> .Row Or .Value <> "" Then GoTo label2
MsgBox "元データから削除する文字列のリストが見つかりません。" & Chr(13) & _
"マクロの実行を中止します。", vbInformation, "データ無し"
Exit Sub
label2:
Set DelStrRange = .Resize(DelStrRB - .Row + 1, 1)
End With

myMsg = MsgBox("このマクロを実行しますと" & OriDataSheet & "の" & PasteColumn _
& "列のデータが上書きされます。" & Chr(13) & "マクロを実行しますか？" & Chr(13) _
& Chr(13) & "[OK]：マクロを実行します" & Chr(13) & "[キャンセル]：マクロを終了します" _
, vbOKCancel + vbQuestion, "確認")
If myMsg = vbCancel Then Exit Sub

Sheets(OriDataSheet).Range(PasteColumn & Range(OriDataFCell).Row & ":" & _
PasteColumn & Range(PasteColumn & Rows.Count).End(xlUp).Row).ClearContents
For Each r1 In OriDataRange
TempStr = r1.Value
For Each r2 In DelStrRange
TempStr = Replace(TempStr, r2.Value, "")
Next r2
r1.Offset(0, OffsetC).Value = TempStr
Next r1

End Sub

回答No.1

bunjii

>データとリストが膨大(今後も随時追加予定)で、自動化することができればと考えております。
関数で処理するには配列演算を使いますので膨大なデータの場合はリソース不足（メモリ不足）で動作しないかも知れません。
提示の模擬データ範囲でExcel 2013で検証しました。
Excel 2007以降のバージョンで再現できるはずです。
データの最大は10行までとしてあります。
Sheet1!A列の文字列にはSheet2!A列の文字列が最大2つまで含むものとしました。
Sheet1!B1へ次の数式を設定して下へ10行目までコピーしたものが貼付画像です。
=SUBSTITUTE(SUBSTITUTE(A1,INDEX(Sheet2!$A:$A,MAX((IFERROR((FIND(Sheet2!$A$1:$A$10,A1)>0)*(Sheet2!$A$1:$A$10<>""),0))*ROW(Sheet2!$A$1:$A$10)),1)&"",""),INDEX(Sheet2!$A:$A,MAX((IFERROR((FIND(Sheet2!$A$1:$A$10,SUBSTITUTE(A1,INDEX(Sheet2!$A:$A,MAX((IFERROR((FIND(Sheet2!$A$1:$A$10,A1)>0)*(Sheet2!$A$1:$A$10<>""),0))*ROW(Sheet2!$A$1:$A$10)),1)&"",""))>0)*(Sheet2!$A$1:$A$10<>""),0))*ROW(Sheet2!$A$1:$A$10)),1)&"","")
この数式は計算過程で配列値を扱いますので、数式入力時にCtrl+Shift+Enterで確定します。

お礼

ありがとうございます。
とても素早くご回答いただけたので驚きました！
SUBSTITUTEの関数は列を指定できるのですね。
単語を入れ子、入れ子、入れ子して途方にくれていました、、、。(恥)
勉強させていただきました！