【Excel VBA】ﾕｰｻﾞｰﾌｫｰﾑで選択した複数条件に一致するデータ行を削除

賞味期限の管理をエクセル管理でやってみようと思っています。
ＶＢＡを使ってﾕｰｻﾞｰﾌｫｰﾑで3つの条件を登録し、シートのデータ表から一致するデータ行を削除しようと思っているのですが、やはり素人のためコードがわからず立ち往生しています。
お力を貸してください。

以下のような仕組みを考えています。

ユーザーフォーム：リストボックスから選択　①”製品名”

　　　　　　　　　テキストボックスで入力　②”賞味期限”の日付(yyyy/mm/dd形式、表も
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　同じ形式で登録されています）
　　　　　　　　　テキストボックスで入力　③”数量”（整数以外に小数点以下の数字もあり）
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　を入力。
コマンドボタンを押すと、シートのデータ表から①~③すべて一致するデータが1行ごとに削除される。(表に該当するデータがない場合は不一致のメッセージ表示もしたいです）

※データ表には重複するデータが多数存在していますが、削除はあくまでボタン押下1回につき１行のデータ削除となります。

ひとつ、これはあってもなくてもいいのですが、実行前に確認メッセージでワンクッションおいてからの削除にしたいです。（例えば”処理してよろしいですか？『YES』or『No』”⇒『YES』⇒削除）

何卒お力添えをよろしくお願いします。

No.2 ベストアンサー 回答者： t_fumiaki 回答日時： 2016/05/11 18:44

下のurlからダウンロードして下さい。

チャント動くエクセルがzip内に入っています。
エクセルを開いてvbaを取り出すか、そのまま使って下さい。
（変なものは入っていません。ご安心下さい）

http://www.tfumi01.com/test/test.html

この回答へのお礼

ご回答ありがとうございます。
特に問題なく動作しました。
重ね重ねですが、ありがとうございました。

お礼日時：2016/05/11 21:10

No.3 回答者： t_fumiaki 回答日時： 2016/05/11 18:53

No.2 補足です。

フォームの製品名には事前に内容をセットしておく必要があります。

Private Sub UserForm_Initialize()
ListBox1.AddItem "りんご"
ListBox1.AddItem "みかん"
ListBox1.AddItem "すいか"
ListBox1.AddItem "梨"
ListBox1.AddItem "柿"
End Sub

でセットしていますので、このPrivate Subに追加セットして下さい。

No.1 回答者： WindFaller 回答日時： 2016/05/11 18:13

私も素人です。

>データ表には重複するデータが多数存在していますが、削除はあくまでボタン押下1回につき１行のデータ削除となります。

同じような質問は、以前にも出ていた気がします。

オートフィルタやテーブルを使った方法がわかりやすいような気がしますが、Findメソッドも健在です。一番、簡単な方法は、やはりループで一行ずつ舐めていく方法ですが、それは、あまり、効率が良くありません。

　'サブプロシージャに飛びます
'　Call FindRow(listItem, txtBx1, txtBx2, Rng))

'//
Private Sub CommandButton1_Click()
　　Dim listItem As String
　　Dim txtBx1 As String
　　Dim txtBx2 As String
　　Dim Rng As Range
　　With ActiveSheet
　　'データ範囲の設定　左上端とその範囲
　　Set Rng = .Range("B3", .Cells(Rows.Count, "B").End(xlUp).Resize(, 4))
　　End With
　　Rng.Select
　　listItem = Me.ListBox1.Text
　　txtBx1 = Trim(Me.TextBox1.Text)
　　If Not IsDate(txtBx1) Then MsgBox "日付値を入れてください (yyyy/mm/dd)": Exit Sub
　　txtBx2 = Trim(Me.TextBox2.Text)
　　If listItem <> "" And txtBx1 <> "" And txtBx2 <> "" Then
　　If Not IsNumeric(txtBx2) Then MsgBox "数値を入れてください": Exit Sub
　　　　Call FindRow(listItem, txtBx1, txtBx2, Rng)
　　Else
　　　　MsgBox "3つの条件が正しく選択・入力されていません", vbCritical
　　End If
End Sub

Sub FindRow(arg1, arg2, arg3, Rng As Range)
　　Dim c As Range
　　Dim Target As Range
　　Dim FirstAddress As String
　　Set Target = Nothing
　　With Rng
　　　　.Cells(1, 1).Select '検索の最初の場所
　　　　Set c = .Columns(2).Find( _
　　　　What:=arg1, _
　　　　LookIn:=xlValues, _
　　　　LookAt:=xlWhole, _
　　　　SearchOrder:=xlByColumns, _
　　　　MatchByte:=False)
　　　　If Not c Is Nothing Then
　　　　　　FirstAddress = c.Address
　　　　　　If c.Offset(, 1).Value = CDate(arg2) Then
　　　　　　　　If c.Offset(, 2).Value = CDate(arg3) Then
　　　　　　　　　　Set Target = c.Rows
　　　　　　　　　　GoTo FinalLine
　　　　　　　　End If
　　　　　　End If
　　　　　　Do
　　　　　　　　Set c = .FindNext(c)
　　　　　　　　If c.Address = FirstAddress Then GoTo FinalLine
　　　　　　　　If c.Offset(, 1).Value = CDate(arg2) Then
　　　　　　　　　　If c.Offset(, 2).Value = CDate(arg3) Then
　　　　　　　　　　　　Set Target = c.Rows
　　　　　　　　　　　　Exit Do
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Loop Until c Is Nothing
　　　　End If
　　End With
FinalLine:
　　If Not Target Is Nothing Then
　　　　Target.Select
　　　　If MsgBox("削除してよろしいですか？", vbQuestion + vbYesNo) = vbYes Then
　　　　　　Application.ScreenUpdating = False
　　　　　　Target.EntireRow.Delete
　　　　　　Application.ScreenUpdating = True
　　　　End If
　　Else
　　　　MsgBox "該当する行は見つかりませんでした。", vbCritical
　　End If
　　Set Target = Nothing
End Sub

この回答へのお礼

動きは思っていたとおりでした。
ただ数量の値が小数点以下のデータの場合、検索ができませんでした。
修正しようも、自分のレベルでは難しいです。
でも勉強になりました。回答ありがとうございます。

お礼日時：2016/05/11 21:07