[[20070115094020]]　『日付の範囲でデータの抜き出し』（メルー）　ページの最後に飛ぶ

『日付の範囲でデータの抜き出し』（メルー）

日付の範囲でデータの抜き出し

いつもお世話になっております。
お知恵を拝借させてください。
一つのBookにある、大量のシートの、
特定列に記載されている日付の範囲でデータを抽出する方法について。

Sheet名

りんご、バナナ、メロン・・

と、並んでいます。

Sheet:りんご

=====================================

 種類	　食べた日　個数　
1 りんご	1/1       3
2 りんご	1/20      5
3 りんご	2/1       1
・
・
======================================

という感じで、A列に種類、B列に日付、C列に個数が並んでいます。
別シートに、すべてのシートから1/1～1/31までに、食べた種類A列と個数C列を、
一括で抽出する方法について教えて下さい。

別シートには、
A1とA2の様に、2つのセル、もしくは入力スペースが並んでいて、
そのセルに入力した日付の間のデータが
抽出されるようにしたいと考えております。

望まれる結果:

別シートに、対象のものが抽出される。

======================================

  種類	　食べた日　個数　
1 りんご	1/1       3
2 りんご	1/20      5
3 バナナ	1/5	  5
4 バナナ	1/8	  5
5 バナナ	1/13	  7
6 バナナ	1/13	  1
7 メロン	1/13	  7
8 メロン	1/13	  12
・
・

======================================

よろしくお願いします。

 こんな感じで如何でしょう？
　
 標準モジュールへコピペ
'-------------------------
Sub メルー()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant, MyKey As Variant
Dim MyData As String
Dim Day1 As Date, Day2 As Date
Dim Sh As Worksheet
Dim i As Long, n As Long, c As Long
    On Error GoTo Exit_Sub
    MyData = StrConv(InputBox("期間を入力してください"), vbNarrow)
    If Len(MyData) = 0 Then Exit Sub
    With CreateObject("VBScript.RegEXP")
        If MyData Like "*-*" Then
            .Pattern = "^(\d{1,2}/\d{1,2})-(\d{1,2}/\d{1,2})$"
            If Not .Test(MyData) Then: MsgBox "入力に誤りがあります。": Exit Sub
            Day1 = Format(.Replace(MyData, "$1"), "yyyy/m/d")
            Day2 = Format(.Replace(MyData, "$2"), "yyyy/m/d")
        Else
            .Pattern = "^(\d{1,2}/\d{1,2})$"
            If Not .Test(MyData) Then: MsgBox "入力に誤りがあります。": Exit Sub
            Day1 = Format(MyData, "yyyy/m/d")
            Day2 = Day1
        End If
        If Day1 > Day2 Then: MsgBox "入力に誤りがあります。": Exit Sub
    End With
    Set MyDic = CreateObject("Scripting.Dictionary")
    For Each Sh In Worksheets
        If Sh.Name <> "集計" Then
            With Sh
                MyA = .Range("A1").CurrentRegion
                For i = 2 To UBound(MyA, 1)
                    If MyA(i, 2) >= Day1 And MyA(i, 2) <= Day2 Then
                        MyDic(Sh.Name & "," & i) = Empty
                    End If
                Next i
            End With
        End If
    Next Sh
    ReDim MyAry(1 To MyDic.Count, 1 To UBound(MyA, 2))
    For Each MyKey In MyDic.keys
        c = c + 1
        For n = 1 To UBound(MyA, 2)
            MyAry(c, n) = Worksheets(Split(MyKey, ",")(0)).Cells(Split(MyKey, ",")(1), n)
        Next n
    Next MyKey
    With Worksheets("集計")
        .Cells.ClearContents
        .Range("A1:C1") = Array("種類", "食べた日", "個数")
        .Range("A2").Resize(MyDic.Count, UBound(MyA, 2)) = MyAry
    End With
Exit_Sub:
    Set MyDic = Nothing: Erase MyA, MyAry
End Sub
　
 Alt + 【F11】で、Microsoft Visual Basic を出す。
 挿入 → 標準モジュール
 出てきた白い画面に上記コードをコピペ
 「×」で、Excel に戻る
 Alt + 【F8】で「メルー」を実行。
　
※「集計」と言う名のシートを作成してください。
　日付の入力は、
　1/1　や　1/1-2/1　等のように入力してください。
　　
 （キリキ）（〃⌒o⌒)b

lmlm
（mllm） 2015/08/30(日) 01:36

 >>別シートには、 A1とA2の様に、2つのセル、もしくは入力スペースが並んでいて

 この意味がちょっとわかりにくいのですが "条件" というシートの A1,A2 に日付型で開始、終了の日付が入っている、
 あるいは、A1にのみ　単一の抽出日付が入っているという前提で。

 キリキさんのコードと同じく、抽出結果は "集計" という名前のシートに展開します。
 単に愚直にループと比較を繰り返す Test1 と オートフィルターを使った　Test2を。

 Sub Test1()
    Dim f As Double
    Dim t As Double
    Dim shF As Worksheet
    Dim shT As Worksheet
    Dim shX As Worksheet
    Dim w As Variant
    Dim c As Range
    Dim x As Long

    Application.ScreenUpdating = False

    Set shT = Sheets("集計")
    Set shX = Sheets("条件")

    f = Sheets("条件").Range("A1").Value2
    t = Sheets("条件").Range("A2").Value2
    If t = 0 Then t = f
    ReDim w(1 To Rows.Count - 1, 1 To 3)

    For Each shF In Worksheets
        Select Case shF.Name
            Case shT.Name, shX.Name
                'Nop
            Case Else
                For Each c In shF.Range("A2", shF.Range("A" & Rows.Count).End(xlUp))
                    If c.Offset(, 1).Value2 >= f And c.Offset(, 1).Value <= t Then
                        x = x + 1
                        w(x, 1) = c.Value
                        w(x, 2) = c.Offset(, 1).Value
                        w(x, 3) = c.Offset(, 2).Value
                    End If
                Next
        End Select
    Next

    shT.Range("A1").CurrentRegion.Offset(1).ClearContents
    shT.Range("A1:C1").Value = Array("種類", "食べた日", "個数")
    If x > 0 Then shT.Range("A2").Resize(x, 3).Value = w
    shT.Select

 End Sub

 Sub Test2()
    Dim f As Double
    Dim t As Double
    Dim shF As Worksheet
    Dim shT As Worksheet
    Dim shX As Worksheet
    Dim r As Range

    Application.ScreenUpdating = False

    Set shT = Sheets("集計")
    Set shX = Sheets("条件")

    f = Sheets("条件").Range("A1").Value2
    t = Sheets("条件").Range("A2").Value2
    If t = 0 Then t = f
    shT.Range("A1").CurrentRegion.Offset(1).ClearContents
    shT.Range("A1:C1").Value = Array("種類", "食べた日", "個数")

    For Each shF In Worksheets
        Select Case shF.Name
            Case shT.Name, shX.Name
                'Nop
            Case Else
                shF.Range("A1").CurrentRegion.Offset(1).Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
        End Select
    Next

    shT.AutoFilterMode = False
    shT.Range("A1").AutoFilter Field:=2, Criteria1:="<" & f, Operator:=xlOr, Criteria2:=">" & t
    Intersect(shT.AutoFilter.Range, shT.AutoFilter.Range.Offset(1)).EntireRow.Delete
    shT.AutoFilterMode = False
    shT.Select

 End Sub

（β） 2015/08/30(日) 06:16

コメント返信：

[ 一覧(最新更新順) ]

[[20070115094020]] 『日付の範囲でデータの抜き出し』（メルー） ページの最後に飛ぶ

[[20070115094020]]　『日付の範囲でデータの抜き出し』（メルー）　ページの最後に飛ぶ