[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『日付の範囲でデータの抜き出し』(メルー)
日付の範囲でデータの抜き出し
いつもお世話になっております。
お知恵を拝借させてください。
一つの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
>>別シートには、 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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.