回答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様を目指して勉強したいと思います。