Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


10961 / 13646 ツリー ←次へ | 前へ→

【18928】条件に合致した行を削除したいのですが・... michiko 04/10/16(土) 21:56 質問[未読]
【18930】Re:条件に合致した行を削除したいのですが... Hirofumi 04/10/16(土) 23:47 回答[未読]
【18931】Re:条件に合致した行を削除したいのですが... かみちゃん 04/10/17(日) 0:30 回答[未読]
【18939】ありがとうございました! michiko 04/10/17(日) 4:22 お礼[未読]

【18928】条件に合致した行を削除したいのですが・...
質問  michiko  - 04/10/16(土) 21:56 -

引用なし
パスワード
   業務で「発注管理台帳」というものを毎月作っています。
今までは、手作業で作成していましたが、このたび、VBAで自動化しようという話になりまして、
VBA初心者の私が、コードを組むことになってしまいました。

この「発注管理台帳」ですが、社内DBに保存されているデータ(約10000件)を
Excelに落としたものを元データとしています。
この元データを台帳に加工する前に、以下の条件に当てはまるデータを削除しなければなりません。

1.列B「注文処理状況」において、「処理済」と入力されている行を削除。
2.列F「納期」(セルの書式:yyyy/mm/dd)が検収月以外で、列H「注文数量」が「1」の行を削除。
たとえば、「検収月」が2004年9月なら、「納期」が「2004/10/01」で「注文数量」が「1」の行は削除。
「納期」が「2004/10/01」で「注文数量」が「2」の行は削除しない。

なお、「検収月」は9月、10月・・というように1ヶ月単位で変わります。
Excelに落としてきた元データの数も、毎月変わります。

条件1.については、以下のような記述でできました。

Sub 条件1に当てはまるデータ削除()

Dim i As Long
For i = Range("B65536").End(xlUp).Row To 2 Step -1
  If Cells(i, 2).Text = "処理済" Then
    Rows(i).Delete
  End If
Next i

End Sub

しかし、条件2.のところでつまづいてしまいました。
「検収月」は毎月変わりますので「検収月を入力してください」という入力フォームを表示してユーザーに入力を促そうと考えていますが、
条件設定になると、完全にお手上げです。

どなたか、お知恵をいただけませんでしょうか?
よろしくお願いいたします。

【18930】Re:条件に合致した行を削除したいのです...
回答  Hirofumi  - 04/10/16(土) 23:47 -

引用なし
パスワード
   こんなので善いのかな?

Public Sub DataDelete()

  Dim i As Long
  Dim strResult As String
  Dim dtmReceived As Date
  
  Do
    strResult = InputBox("検収月を" & Format(Date, "yyyy/m") _
            & "の形で入力して下さい", "検収月入力", _
                Format(Date, "yyyy/m"))
    If strResult = "" Then
      Exit Sub
    Else
      If IsDate(strResult & "/1") Then
        dtmReceived = DateValue(strResult & "/1")
        Exit Do
      Else
        Beep
        MsgBox "入力が違います"
      End If
    End If
  Loop
  
  Application.ScreenUpdating = False
  
  For i = Range("B65536").End(xlUp).Row To 2 Step -1
    If RowDelete(Cells(i, "B").Value, _
        Cells(i, "F").Value, _
          Cells(i, "H").Value, dtmReceived) Then
      Rows(i).Delete
    End If
  Next i
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Function RowDelete(vntOrder As Variant, _
              vntDelivery As Variant, _
              vntQuantity As Variant, _
              dtmTop As Date) As Boolean

  Dim dtmLast As Date
  
  dtmLast = DateSerial(Year(dtmTop), _
            Month(dtmTop) + 1, 0)
  RowDelete = True
  
  If vntOrder = "処理済" Then
    Exit Function
  End If
  
  If vntQuantity = 1 Then
    If vntDelivery < dtmTop _
        Or dtmLast < vntDelivery Then
      Exit Function
    End If
  End If
  
  RowDelete = False
  
End Function

【18931】Re:条件に合致した行を削除したいのです...
回答  かみちゃん  - 04/10/17(日) 0:30 -

引用なし
パスワード
   こんちには。かみちゃん です。

>「検収月」は毎月変わりますので「検収月を入力してください」という入力フォームを表示してユーザーに入力を促そうと考えていますが、
>条件設定になると、完全にお手上げです。

検収月入力部分は、Hirofumiさんご提示のコードを流用させていただきましたが、削除部分は、オートフィルタで一致した条件を削除しています。
特に、条件2の「検収月以外」というものは、「検収月の最初の日より小さく、検収月の末日より大きい」という条件にしているところがポイントです。

Option Explicit

Sub Macro1()
  Dim i As Long
  Dim strResult As String
  Dim dtmReceived1 As Date, dtmReceived2 As Date
 
  '検収月の入力
  Do
    strResult = InputBox("検収月を" & Format(Date, "yyyy/m") _
            & "の形で入力して下さい", "検収月入力", _
                Format(Date, "yyyy/m"))
    If strResult = "" Then
      Exit Sub
    Else
      If IsDate(strResult & "/1") Then
        '検収月の初日
        dtmReceived1 = DateValue(strResult & "/1")
        '検収月の末日
        dtmReceived2 = DateAdd("m", 1, DateValue(strResult & "/1")) - 1
        Exit Do
      Else
        Beep
        MsgBox "入力が違います"
      End If
    End If
  Loop
  
  '表の範囲がA1から始まるものとして
  Range("A1").CurrentRegion.AutoFilter
  '列Bが「処理済」を削除
  With ActiveSheet.AutoFilter.Range
    .AutoFilter Field:=2, Criteria1:="処理済"
    .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) _
      .EntireRow.Delete Shift:=xlUp
  End With
  ActiveSheet.ShowAllData
  '列Fが「検収月」以外で、列Hが「1」の場合は削除
  With ActiveSheet.AutoFilter.Range
    .AutoFilter Field:=6, Criteria1:="<" & dtmReceived1, Operator:=xlOr, _
      Criteria2:=">" & dtmReceived2
    .AutoFilter Field:=8, Criteria1:="1"
    .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) _
      .EntireRow.Delete Shift:=xlUp
  End With
  Selection.AutoFilter
  Range("A1").Select
End Sub

【18939】ありがとうございました!
お礼  michiko  - 04/10/17(日) 4:22 -

引用なし
パスワード
   >Hirofumiさん、かみちゃんさん

早々のご回答ありがとうございます。

おかげさまで、ここ1週間(!)悩んでいた部分が解決しました。
(お二人とも短時間でこれだけのコードを書かれて素晴らしいなと思いました。
1週間は、悩み過ぎですよね・・)

頂いたコードで、思い通りの結果が出て感激しています。
やっぱり、思い切って質問して良かったです。
特に日付の条件設定の部分は勉強になりました。

10961 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free