EXCEL 一覧表の頭記号と一致した行のみ削除

質問

規格部品として頭に２桁又は３桁の記号+数字が付いた規格部品があります。（一覧表有り）
例）
PA, PG, QA, SB, BAA等複数＜記号の後に続く数字の桁数は不統一です。＞

今回作成する個別リスト上のE列に全部品の品番が記載されていますが、規格部品が記載されている行のみを一括削除出来ればと考えています。
そのようなことが可能なのかわかりませんが、マクロの詳しい方がおりましたら是非教えて下さい。
尚、一覧表は別ファイルですが、別シート(SHEET2)に貼り付けてからでも可能です。
宜しくお願いします。

PS: EXCEL2003を利用しています。

回答No.5

tom04 · ベストアンサー

No.2・3です。

No.2の画像通りの配置だとすると
Sheet2の「規格品コード」の数字より前の部分がSheet1のE列と同じ場合、その行を削除すればよい訳ですよね？

コードを↓に変更してみてください。

Sub Sample2()
Dim i As Long, k As Long, lastRow As Long, lastCol As Long
Dim str As String, buf As String, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To Len(wS.Cells(i, "A"))
str = Mid(wS.Cells(i, "A"), k, 1)
If Not str Like "[0-9]" Then
buf = buf & str
Else
Exit For
End If
Next k
.Range("A1").AutoFilter field:=5, Criteria1:=buf & "*"
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
End If
.AutoFilterMode = False
buf = ""
Next i
End With
Application.ScreenUpdating = True
End Sub

※　今回もNo2の画像の配置通りとします。
（列は1行目の項目が入っていれば何列あっても構いません）m(_ _)m

お礼

お世話になります。
再度回答有難うございます。
大変恐縮ですが、やはり上手くいきませんでした。
リストのデータが全て消えてしまいます。
明日、もう一度トライしてみます。

補足

お世話になります。
ご連絡が遅くなり申し訳ありません。
再度トライしたところ、Sheet2に記載の規格部品リストの行間が所々空白になっているところが有り、空白が無いようにして再トライしてみました。
感激です。
完璧に一括削除出来ました。
有難うございました。

回答No.6

keithin

＞削除されず残っている行は末尾に記号付きのもののように思います

再掲：
＞シート２のＡ２以下に、削除したい言葉そのものを記入する
　PA
　PG
　QA
　BAA
　：
＞のように

回答で説明さしあげている通り，たとえば
AH06130MBF
なら，実際に削除したい対象となる文字だけを残して
AH
となってなきゃダメということです。

後ろにまた文字が現れるというのは「元々は無かった条件」なので，当然ダメですね。

やり直し：
sub macro0()
　dim i as integer
　for i=0 to 9
　worksheets("Sheet2").range("A:A").replace what:=i & "*", replacement:="", lookat:=xlpart
　next i
end sub

他は先の回答の手順通りなので，間違えないようよく見直しながら実施して下さい。

お礼

お世話になります。
お忙しいところ回答有難うございます。
Sheet1の本リスト上では「頭記号+数字+記号」のまま、他部品品番と複数混在していますが、Sheet2の規格部品リストA列上では頭記号のみになっています。
その状態でメインマクロを実行してみましたが、規格部品全てを削除することが出来ませんでした。
※１行目のタイトル行も消えてしまいます。
説明不足でも想定して対応して頂き、大変感謝しています。
有難うございました。

回答No.4

nishi6

マクロが目的でしょうか？この程度の処理なら下記の手順で可能です。いつも、マクロを書くよりも速く終わっています。やっていることが見えるのが一番いいです。目的のデータにエラーを発生させ一括処理の対象としてつかめるようにしています。

ご参考に。

規格部品の表がH11:H13にあったとして、例えばF列が使えるとして、

１．添付図のような状態でF2セルに
　=IF(ISERROR(VLOOKUP(E2,$H$11:$H$13,1,0)),E2,1/0)
と入力し、下にコピーします。規格部品の場合、エラーになります。

２．F列の算式をすべて選択状態のまま、ファンクションキーF5を押します。
３．ジャンプダイアログボックスでセル選択ボタンをクリック。
４．選択オプションダイアログボックスで数式のエラー値のみにチェックしてOK。
５．カレントセルで右クリックして「削除」を選択。
６．削除選択ボックスで「行全体」をオンにしてOK。
７．終わったらF列は始末します。

お礼

お世話になります。
回答有難うございます。
私の説明不足なのか、規格部品についてもなぜか？エラーが出ませんでした。
でも、マクロ以外でも遣り方があるのだと勉強になりました。
お手数おかけしました。

回答No.3

tom04

No.2です。

タイトルの
＞・・・一覧表の頭記号と・・・
を見逃していました。

前回のコードは完全一致となりますので、
No.1さんの方法が正しいです。

どうも失礼しました。m(_ _)m

お礼

コメント頂き有難うございます。
失礼だなんて少しも思いません。
条件次第でいろいろと変わるものだと勉強になります。
お手数おかけしました。

回答No.2

tom04

こんばんは！

↓の画像のように元データは左側のSheet1にあり、
規格品コードは右側のSheet2のような配列になっているという前提です。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, lastRow As Long, lastCol As Long
Dim c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
Set c = .Range("E:E").Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Range("A1").AutoFilter field:=5, Criteria1:=wS.Cells(i, "A")
Range(.Cells(2, "A"), .Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
End If
.AutoFilterMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub

※　元データそのものを削除するようにしていますので
別Sheetでマクロを試してみてください。m(_ _)m

お礼

お世話になります。
お力をお貸しして頂き有り難く思っていますが、なぜか全て削除されてしまいます。
まだまだ私には力不足で、どう修正するべきかもわかりませんが、回答して頂き感謝しています。
有難うございます。

回答No.1

keithin

シート１の１行目にタイトル行
２行目からデータ
Ｅ１セルにＥ列のタイトルとして「何某」と記入されている

準備：
シート２のＡ１セルにシート１のＥ１と同じ「何某」と記入する
シート２のＡ２以下に、削除したい言葉そのものを記入する
PA
PG
QA
BAA
：
のように

【参考】
手を動かして元リストから不要な数字を削除することがどーしてもできない場合：
シート２のＡ１以下に
何某
PA123456
PG22345
BAA333456
　：
のように、元データをとにかく列挙する

ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro0()
　dim i as integer
　for i=0 to 9
　worksheets("Sheet2").range("A:A").replace what:=i, replacement:="", lookat:=xlpart
　next i
end sub

ファイルメニューから終了してエクセルに戻る
ＡＬＴ＋Ｆ８を押してマクロを実行する

以上で削除したい正しいリストが準備出来たら

本番：
ＡＬＴ＋Ｆ１１を押す
標準モジュールを挿入する
下記をコピー貼り付ける

sub macro1()
　worksheets("Sheet1").select
　range("E:E").advancedfilter _
　　action:=xlfilterinplace, _
　　criteriarange:=worksheets("Sheet2").range("A1").currentregion, _
　　unique:=false

　range("E2:E" & range("E65536").end(xlup).row).specialcells(xlcelltypevisible).entirerow.delete shift:=xlshiftup
　activesheet.showalldata
end sub

マクロを実行して完成。

お礼

お世話になります。
お忙しい中いつも有難うございます。
申し訳ありませんが、規格部品全てが削除されず、いろいろと試しているのですが上手くいきません。
一つだけ質問させて頂いても良いでしょうか？
規格部品の品番ですが、頭に「記号+数字」と記載しましたが、下記のように「記号＋数字+記号」となっている部品品番もあります。
例）
AH06130MBF
AH05065M
QP10010P
削除されず残っている行は末尾に記号付きのもののように思いますが、何かマクロの改良が必要なのでしょうか？
ご教示して頂けると助かります。
お手数おかけします。