【マクロ】表から条件に合うデータを別シートに抽出したい

初心者です。
ご教授ください！

Sheet1の画像の表のB1に日付を入力してくださいした際にSheet1のG列の日付順に別シート(Sheet2)へデータを抽出することはできませんか？
Sheet1の情報は編集されるので自動的に反映されるようにしたいです。
また、抽出後のソートやフィルタオプションは避けたいです。

わかりにくい質問で申し訳ありませんが、どなたかわかる方、アドバイス頂ける方がいらっしゃいましたら教えてください。
よろしくお願い致します。m(_　_)m

質問者からの補足コメント

• すみません！
  日付順でなくてOKです。
  Sheet1のB1に日付を入力、もしくはボタンをつけてクリックしたら
  B1＝納入日の行をSheet2に抽出したいです。。

  No.1の回答に寄せられた補足コメントです。 補足日時：2015/11/16 14:27

No.2 ベストアンサー 回答者： xMAKISHIx 回答日時： 2015/11/16 16:29

Option Explicit

Private Const lngNoCol　　　　　As Long = 2
Private Const lngHinNameCol　　As Long = 3
Private Const lngOkurisakiCol　　As Long = 4
Private Const lngSyubetsuCol　　As Long = 5
Private Const lngSyukkaCol 　As Long = 6
Private Const lngNounyudayCol　As Long = 7

Private Const strSheetName　　 As String = "Sheet1"

Private Sub Worksheet_Change(ByVal Target As Range)

　　Dim objWorkbook As Workbook
　　Dim objWorkSheet As Worksheet
　　Dim objDaySheet As Worksheet
　　Dim objRange As Range
　　Dim lngStartRow As Long
　　Dim lngMaxRow As Long
　　Dim lngRow As Long
　　Dim lngCol As Long

　　If (Target.Column > 2 Or Target.Column < 2 Or Target.Row > 1) Then
　　　　Exit Sub
　　End If

　　With Application
　　　　.EnableEvents = False
　　　　.ScreenUpdating = False
　　　　.Calculation = xlCalculationManual
　　End With

　　Set objWorkbook = Workbooks(ThisWorkbook.Name)
　　Set objWorkSheet = objWorkbook.Sheets(strSheetName)

　　With objWorkSheet
　　　　For Each objDaySheet In Worksheets
　　　　　　If objDaySheet.Name = Mid(.Cells(1, 2), 1, 4) & Mid(.Cells(1, 2), 6, 2) & Mid(.Cells(1, 2), 9, 2) Then
　　　　　　　　MsgBox "すでにシートがあります。"
　　　　　　　　GoTo ExitProc
　　　　　　End If
　　　　Next objDaySheet
　　End With

　　lngMaxRow = objWorkSheet.Cells(Rows.Count, lngNounyudayCol).End(xlUp).Row

　　Set objRange = Range(objWorkSheet.Cells(4, lngNounyudayCol), objWorkSheet.Cells(lngMaxRow, lngNounyudayCol)).Find(What:=objWorkSheet.Cells(1, 2))

　　If Not objRange Is Nothing Then
　　　　objWorkbook.Sheets.Add After:=objWorkbook.Worksheets(objWorkbook.Worksheets.Count)

　　　　With objWorkSheet
　　　　　　　　objWorkbook.ActiveSheet.Name = Mid(.Cells(1, 2), 1, 4) & Mid(.Cells(1, 2), 6, 2) & Mid(.Cells(1, 2), 9, 2)
　　　　　　　　Set objDaySheet = objWorkbook.Sheets(Mid(.Cells(1, 2), 1, 4) & Mid(.Cells(1, 2), 6, 2) & Mid(.Cells(1, 2), 9, 2))
　　　　End With

　　　　For lngCol = lngNoCol To lngNounyudayCol
　　　　　　　　objDaySheet.Cells(1, lngCol - 1).Value = objWorkSheet.Cells(3, lngCol)
　　　　Next lngCol

　　　　lngStartRow = 4
　　　　lngRow = 2
　　　　Do While objWorkSheet.Cells(lngStartRow, lngNounyudayCol) <> ""
　　　　　　If objWorkSheet.Cells(lngStartRow, lngNounyudayCol) = objWorkSheet.Cells(1, 2) Then

　　　　　　　　With objDaySheet
　　　　　　　　　　.Cells(lngRow, lngNoCol - 1) = objWorkSheet.Cells(lngStartRow, lngNoCol)
　　　　　　　　　　.Cells(lngRow, lngHinNameCol - 1) = objWorkSheet.Cells(lngStartRow, lngHinNameCol)
　　　　　　　　　　.Cells(lngRow, lngOkurisakiCol - 1) = objWorkSheet.Cells(lngStartRow, lngOkurisakiCol)
　　　　　　　　　　.Cells(lngRow, lngSyubetsuCol - 1) = objWorkSheet.Cells(lngStartRow, lngSyubetsuCol)
　　　　　　　　　　.Cells(lngRow, lngSyukkaCol - 1) = objWorkSheet.Cells(lngStartRow, lngSyukkaCol)
　　　　　　　　　　.Cells(lngRow, lngNounyudayCol - 1) = objWorkSheet.Cells(lngStartRow, lngNounyudayCol)
　　　　　　　　　　.Cells(lngRow, lngNounyudayCol - 1).NumberFormatLocal = "yyyy/mm/dd"
　　　　　　　　End With

　　　　　　　　lngRow = lngRow + 1
　　　　　　End If

　　　　　　lngStartRow = lngStartRow + 1
　　　　Loop

　　Else
　　　　MsgBox "日付がありませんでした。"
　　　　GoTo ExitProc
　　End If

ExitProc:
　　With Application
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　　　.Calculation = xlCalculationAutomatic
　　End With
End Sub

こんな感じでどうでしょうか？

日付けを変更するとその日付けのシートを作成しそのデータのみを日付シートに書き込みます。

この回答へのお礼

回答ありがとうございました！
凄いです！天才ですか！？凄い！(*ﾟДﾟ艸)

お礼日時：2015/11/17 17:02

No.3 回答者： hallo-2007 回答日時： 2015/11/16 22:55

勝手に質問を解釈してお答えします。

（一応、マクロ案です）
データのシート（Sheet1）
　　A　　B　　　C　　　E　　　F　　G
１　NO　品名　送り先　種別　出荷　納品日
２
と一行目に項目を入れて、二行目以下にデータを入れる形にします。

抽出のシート（Sheet2)
　　A　　B　　　C　　　E　　　F　　G
１　納品日
２
３　NO　品名　送り先　種別　出荷　納品日

と、A1セルに抽出したい項目、A２セルに　抽出する日付を入れるとします。
3行目に、更に項目名を入れておきます。

Sheet2の名前のタブを右クリック、コードの表示をクリックして
VBエディターが起動したら

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
Sheets("Sheet1").Columns("A:G").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:B2"), CopyToRange:=Range("A3:G3"), Unique:=False
End If
End Sub

を張り付けて、VBエディターを閉じる。
Sheets2のA2セルに日付を入れると
納入日が、その日付のデータだけが4行目以下に表示されます。
このマクロは、フィルターオプションをマクロ化したものです。


参考までに、納入日が日付順に並んでいれば、簡単な関数でも安納です。
提示してあるシートでも可能ですが、データは1行目に項目、2行目以下にデータを入力する事が鉄則と思ってください。
あくまでも出荷日＝納入日　として考えました。

No.1 回答者： CoalTar 回答日時： 2015/11/16 14:05

https://oshiete.goo.ne.jp/qa/9111023.html
マクロにしても関数にしても、結果をどのようにしたいかが示されていません

題目は抽出ですが
＞日付順に別シート(Sheet2)へデータを抽出することはできませんか？
「日付順」ということは並べ替えです。どちらでしょう？
また、抽出だとして 納入日=出荷日のみを抽出するのでしょうか？

(トリガ)条件の質問文がわかりにくいです
>Sheet1の画像の表のB1に日付を入力してくださいした際に
InputBox("日付を入力してください")
のようにメッセージを出せってことかなぁ

この回答へのお礼

わかりにくくてすみませんでした(´Д｀;)
回答ありがとうございます。

お礼日時：2015/11/17 16:59