エクセルの学校


[[20070115094020]] 『日付の範囲でデータの抜き出し』(メルー) >>BOT

[ 初めての方へ | 一覧(最新更新順) |

|
| 全文検索 | 過去ログ | HOME ]

 

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

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

いつもお世話になっております。
お知恵を拝借させてください。
一つの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

コメント:

[ 一覧(最新更新順) |

]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.