『日付指定＆文字列指定行を別シートに作成するマクロ』（のぞむ）

どうか助けてください。。

やりたいことは、以下の通りです。
Sheet1 元データに、
・A列〜C列には、番号や各種項目。
・D列以降に日付ごとの実験結果(数字&文字列）が入力されている。

日付と文字列を指定すると、
その日付列に指定した文字列入っている行だけの
新しい表を別シートに作成したい。（元データはそのままにしたい。）
指定する文字列は、ただ今のところ３つ〜５つ程です。

＜具体例＞
（元データ）
   A   B   C   D   E   F   G
1 -    -   -   1   2   3   4
2 1234 X   X   DD  BB  CC  DD
3 2345 X   X   AA  CC  AA  BB
4 3456 X   X   DD  BB  AA  DD
5 4567 X   X   AA  CC  DD  CC
6 5678 X   X   AA  AA  CC  DD
7 6789 X   X   DD  BB  AA  BB
8 7890 X   X   BB  BB  BB  AA
9 8901 X   X   AA  CC  CC  BB
.
.
↓
【日付】3日
【指定文字列】CCとAA
と指定すると・・・

（別シート）
   A   B   C   D   E   F   G
1 -    -   -   1   2   3   4
2 1234 X   X   DD  BB  CC  DD
3 2345 X   X   AA  CC  AA  BB
4 3456 X   X   DD  BB  AA  DD
5 5678 X   X   AA  AA  CC  DD
6 6789 X   X   DD  BB  AA  BB
7 8901 X   X   AA  CC  CC  BB

日付と文字列の指定方法は、

◆どこかに専用のセルを作成し、その横にマクロを登録したボタンを置いて、
専用セルに日付と文字列を入力した後、マクロ登録ボタンを押したら別シートが出来る。

◆ユーザーフォームを利用し、
マクロ登録ボタンを押すとユーザーフォームが出てきて、
そこの欄に日付と文字列を入力して、実行ボタンを押すと別シートが出来る。

などをイメージしております。
可能であれば、今後の勉強のため、
ユーザーフォームを利用した方法をご教示頂けると幸いです。

何卒よろしくお願い致します。



＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
----
 1行目の日付は　単純な数字で　1,2,3 なんですか？　それとも日付型で表示書式で 1,2,3 になっているんですか？
 それと、1,2,3,・・・・と最後まで連続してあるのですか？
 それとも 1,2,4,5,8,10,25,・・・　といったように実験日だけになっているのですか？

（β） 2015/01/28(水) 14:21
----
詳細設定（フィルターオプションの設定）のマクロ化はいかがでしょう。
（串） 2015/01/28(水) 14:25
----
 そうですね。ぴったりだと思います。

（β） 2015/01/28(水) 14:38
----
 前提として 1行目が D1から右に、連続して、31まで入っているものとします。
 元シート名、転記シート名は実際のものになおしてください。

 Sub Test()
    Dim n As Long
    Dim s As String
    Dim v As Variant
    Dim r As Range
    Dim c As Range
    
    Do
        n = Application.InputBox("日付を1〜31でいれてください", Type:=1)
        If n = 0 Then Exit Sub  'キャンセルボタン
        If n >= 1 And n <= 31 Then Exit Do
    Loop
    
    s = Application.InputBox("抽出コードをいれてください。" & vbLf & "AA,BB,CC のように複数指定可能です。", Type:=2)
    If s = "False" Then Exit Sub
    
    v = Split(s, ",")
    
    Set r = Sheets("Sheet1").Range("A1").CurrentRegion  '元シート
    
    With Sheets("Sheet2")                               '転記シート
        .Cells.Clear
        r.Rows(1).Copy .Range("A1")
        Set c = .Cells(1, r.Columns.Count + 2)
        c.Value = .Range("D1").Offset(, n - 1).Value
        c.Offset(1).Resize(UBound(v) + 1).Value = WorksheetFunction.Transpose(v)
        r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c.CurrentRegion, _
                                        CopyToRange:=.Rows(1).Resize(1, r.Columns.Count), Unique:=False
        c.EntireColumn.Clear
        .Select
    End With
    
 End Sub

（β） 2015/01/28(水) 14:51
----
可能であれば、今後の勉強のため、 
ユーザーフォームを利用した方法をご教示頂けると幸いです。 

 熱意はかうけど、一歩、一歩がいいのでは？

 そう思うけど、とりあえず、その勉強材料として。

 UserForm1 のうえに　TextBox1 と　ListBox1　と CommandButton1 を配置。
 ListBox1にコードが表示されるので選択。Ctrlを押しながら複数選択可能。
 また、何かを選び、そのあとShiftキーを押して別のものを選ぶと、その範囲がすべて選ばれる。
 TextBox1には 1〜31 の数字を入力。入力が終わったらCommandButton1をクリック。

 「標準モジュール」

 Sub Test2()
    UserForm1.Show
 End Sub

 「ユーザーフォームモジュール」

 Private Sub UserForm_Initialize()
    Dim dic As Object
    Dim c As Range
    Dim r As Range
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet1").Range("A1").CurrentRegion   '元シート
        Set r = .Cells.Offset(1, 3).Resize(.Rows.Count - 1, .Columns.Count - 3)
        For Each c In r
            dic(c.Value) = True
        Next
    End With
    
    With ListBox1
        .MultiSelect = fmMultiSelectExtended
        .List = dic.keys
    End With
    
    Set dic = Nothing
    
 End Sub

 Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    Dim ok As Boolean
    Dim n As Variant
    
    With TextBox1
        n = .Value
        
        If IsNumeric(n) Then
            If n >= 1 And n <= 31 Then ok = True
        End If
        
        If ok Then Exit Sub
        
        MsgBox "1〜31の数字で入れてください"
        Cancel = True
        .SelStart = 0
        .SelLength = Len(.Value)
    End With
        
 End Sub

 Private Sub CommandButton1_Click()
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim v() As Variant
    Dim r As Range
    Dim c As Range
    Dim x As Long
    
    If Len(TextBox1.Value) = 0 Then
        MsgBox "日付が未入力です"
        Exit Sub
    End If
    
    n = TextBox1.Value
    
    ReDim v(1 To ListBox1.ListCount)
    
    For i = 1 To ListBox1.ListCount
        If ListBox1.Selected(i - 1) Then
            x = x + 1
            v(x) = ListBox1.List(i - 1)
        End If
    Next
    
    If x = 0 Then
        MsgBox "抽出コードが選択されていません "
        Exit Sub
    End If
    
    ReDim Preserve v(1 To x)
    
    Set r = Sheets("Sheet1").Range("A1").CurrentRegion  '元シート
    
    With Sheets("Sheet2")                               '転記シート
        .Cells.Clear
        r.Rows(1).Copy .Range("A1")
        Set c = .Cells(1, r.Columns.Count + 2)
        c.Value = .Range("D1").Offset(, n - 1).Value
        c.Offset(1).Resize(UBound(v)).Value = WorksheetFunction.Transpose(v)
        r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c.CurrentRegion, _
                                        CopyToRange:=.Rows(1).Resize(1, r.Columns.Count), Unique:=False
        c.EntireColumn.Clear
        .Select
    End With
    
    Unload Me
    
 End Sub


 
（β） 2015/01/28(水) 15:43
----
串さん

すぐにご回答頂きありがとうございます！
早速検索したところ以下の応用できそうなコードを発見しました！

しかし、1行目に日付が入ってしまっているのですが、
この日付を同じように抽出条件シートに入力して指定するにはどのようにコードを書き直せばよろしいでしょうか…？

(例）抽出条件シートに
   A       B        C       D   
1 日付     結果     B列項目 C列項目
2 1/1      AA
3          CC

==========
Sub　フィルタオプション（）
Dim myData as range
Dimmycriteria as range

'「データ」シートのデータ範囲をmydataという変数に入れる
Set myData=Worksheets("データ").range("A1").Currentregion
'「抽出条件」シートの抽出条件の設定範囲をmyCriteriaという変数に入れる
Set myCriteria=Worksheets("抽出条件").range("A1").Currentregion

'「抽出」シートで
With Worksheets（"抽出"）
’抽出データをクリアする
.Cells.Clear
'myDataをデータ範囲としてmyRangeを抽出条件として
’フィルタオプションで「抽出」シートのA3セル基準に抽出
myData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=myCriteria,_
CopyToRange:=Range("A3"),Unique:=False
End with
EndSub
==========


βさん

こんなにすぐに回答をいただけるとは…感謝です！
早速やってみたところばっちり動きました！！

大変恐縮ですが、以下の点について教えて頂けますでしょうか？
・日付表示が実は、1/1,1/2・・・というようにしたかったです。。。すみません。
　どのようにコードを変更すればよろしいでしょうか？
・抽出コードを"AA"としたところ"AAA"も一緒に出てきてしまいます。。
　完全一致でいいのですが、その場合はどうすればいいでしょうか＞＜？
・今回ご教示頂いた抽出コードを都度選ぶマクロと抽出コードを
　（たとえば）"AA"と"CC"を出す機会が圧倒的に多いので、日付指定だけする
　マクロも作りたい場合は、どこを省略すればいいでしょうか？
　串さんからご提案頂いた、フィルターオプションのマクロ化にして
　デフォルトで"AA"と"CC"をセルに入力するようにしておけば解決するでしょうか？

お忙しいところ本当に申し訳ございませんが、
初心者なものでどうか今一度ご教示お願い致します。

（のぞむ） 2015/01/29(木) 13:36
----
 日付について、ダイアログで指定する日付のことをいってる？
 もし、そうじゃなく、シート上の日付の値のことなら、コードでは、日付をチェックせず、
 ダイアログで入力された1〜31の数字から、Ｄ列以降のどの列かを判断しているので変更は不要。

 抽出コードについては、もし、デフォルトが常に AA,BB だとして、それをダイアログ表示の際に、セットしてやり
 変更なければ、そのままＯＫをおすというのは、いかがですか。

 部分一致から、完全一致の件、了解。

 で、以下で試してみてください。

 Sub Test()
    Dim n As Long
    Dim s As String
    Dim v As Variant
    Dim r As Range
    Dim c As Range
    Dim x As Long
    
    Do
        n = Application.InputBox("日付を1〜31でいれてください", Type:=1)
        If n = 0 Then Exit Sub  'キャンセルボタン
        If n >= 1 And n <= 31 Then Exit Do
    Loop
    
    s = Application.InputBox("抽出コードをいれてください。" & vbLf & "AA,BB,CC のように複数指定可能です。", Default:="AA,BB", Type:=2)
    If s = "False" Then Exit Sub
    
    v = Split(s, ",")
    For x = LBound(v) To UBound(v)
        v(x) = "=""=" & v(x) & """"
    Next
    Set r = Sheets("Sheet1").Range("A1").CurrentRegion  '元シート
    
    With Sheets("Sheet2")                               '転記シート
        .Cells.Clear
        r.Rows(1).Copy .Range("A1")
        Set c = .Cells(1, r.Columns.Count + 2)
        c.Value = .Range("D1").Offset(, n - 1).Value
        c.Offset(1).Resize(UBound(v) + 1).Value = WorksheetFunction.Transpose(v)
        r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c.CurrentRegion, _
                                        CopyToRange:=.Rows(1).Resize(1, r.Columns.Count), Unique:=False
        c.EntireColumn.Clear
        .Select
    End With
    
 End Sub

（β） 2015/01/29(木) 13:57
----
詳細設定で実行されるなら、日付が項目名になります。
  A
1 1/1
2 AA
3 CC
4 
 
（串） 2015/01/29(木) 17:49