VBA 期間を指定してデータを別シートに抽出

質問

sheet1に下記のような（例）データベースがありＡ～Ｎ列までデータが入力されています。

Ａ　 Ｂ　　Ｃ　　Ｄ　　Ｅ　　Ｆ　　Ｇ　　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　 Ｎ
1　りんご　○○ BA 2526　 ○ 　あお *** *** *** *** *** *** 2015/7/1
2　みかん　××　 BC　 2526 ○ 　あお 2015/8/1
3　すいか　●●　 BB　 2429　 ●　 あか 2015/8/12
4　メロン　□□　 DC　 2355 □　 あか 2015/7/13
5　バナナ　○×　 FE　 2526　 ○　 あお 2015/6/1
6　いちご　●□　 LA　 2429　 ●　 あお 2015/8/21
7　ぶどう　□○　 HK　 2526　 □　 あか 2015/8/7

「sheet1」N列の日付を元にして、別シート（sheet2）のA2列に「開始日付(yyyy/mm/dd」、B2列に「終了日付（yyyy/mm/dd」（例：2015/8/1～2015/8/31）を入力し、フォームボタン（例：抽出）で検索を開始し、抽出された結果のsheet1のA列～G列、N列のみ（H列～M列は不要）をSheet2のA7以下へ表示したいと考えています。

Ａ　 Ｂ　　 Ｃ　　Ｄ　　Ｅ　　Ｆ　　Ｇ　　　Ｎ
2　みかん　××　 BC　 2526 ○ 　 あお 2015/8/1
3　すいか　●●　 BB　 2429　 ●　 あか 2015/8/12
6　いちご　●□　 LA　 2429　 ●　 あお 2015/8/21
7　ぶどう　□○　 HK　 2526　 □　 あか 2015/8/7

期間を指定し検索した結果を別のシートへ表示するにはどのようなVBAのコードを使用すれば良いでしょうか。

宜しくお願いします。

回答No.3

kagakusuki · ベストアンサー

>Sheet2のA7以下へ表示したいと考えています。

の下には

>Ａ　 Ｂ　　 Ｃ　　Ｄ　　Ｅ　　Ｆ　　Ｇ　　　Ｎ

とありますが、その最後にある「N」は、もしかしますと「H」の間違いではないでしょうか?
　それともSheet２においても日付はN列に表示されるようにした方が宜しいのでしょうか?

　取り敢えず、前者の条件であるものとした場合には、以下の様なVBAとなります。

Sub QNo8998854_VBA_期間を指定してデータを別シートに抽出()

Dim CopySheet As Worksheet, PasteSheet As Worksheet, _
ItemRow As Long, LastRow As Long, PasteCell As Range, _
CopyColumn As String, UnwantedColumn As String, _
StartDay As Variant, LastDay As Variant, _
StartDayCell As Range, LastDayCell As Range

Set CopySheet = Sheets("Sheet9") '元データが入力されているシート
Set PasteSheet = Sheets("Sheet9 (2)") '貼付け先のシート
CopyColumn = "A:N" 'コピーする元データが入力されている列の範囲
UnwantedColumn = "H:M" 'コピーする必要のない列の範囲
ReferenceColumn = "N" '日付けが入力されている列
ItemRow = 1 ' 元データの表の項目欄の行番号
Set PasteCell = PasteSheet.Range("A7") '貼付け先のセル範囲の中で最も左上にあるセル
Set StartDayCell = PasteSheet.Range("A2") '期間の初日の日付が入力されているセル
Set LastDayCell = PasteSheet.Range("B2") '期間の最終日の日付が入力されているセル

StartDay = StartDayCell.Value
LastDay = LastDayCell.Value
If StartDay = "" Or LastDay = "" Then
MsgBox "期間が設定されておりません。", vbExclamation, "期間未設定"
Exit Sub
ElseIf StartDay > LastDay Or Not (IsDate(StartDay) And IsDate(LastDay)) Then
MsgBox "期間の設定が不適切です。", vbExclamation, "無効な設定値"
Exit Sub
End If
LastRow = CopySheet.Range(ReferenceColumn & Rows.Count).End(xlUp).Row
If LastRow <= ItemRow Or WorksheetFunction. _
CountIfs(CopySheet.Range(ReferenceColumn & ItemRow & ":" & ReferenceColumn & LastRow), ">=" _
& StartDay, CopySheet.Range(ReferenceColumn & ItemRow & ":" & ReferenceColumn & LastRow), _
"<" & LastDay + 1) = 0 Then
MsgBox "抽出すべきデータがありません。", vbInformation, "データ無し"
Exit Sub
End If

Application.ScreenUpdating = False
With CopySheet
If .AutoFilterMode Then CopySheet.Cells.AutoFilter
.Columns(UnwantedColumn).EntireColumn.Hidden = True
.Range(ReferenceColumn & ItemRow & ":" & ReferenceColumn & LastRow). _
AutoFilter Field:=1, Criteria1:=">=" & Int(StartDay), Criteria2:="<" & Int(LastDay) + 1
Intersect(.Columns(CopyColumn), .Rows(ItemRow & ":" & LastRow)).SpecialCells(xlCellTypeVisible).Copy
PasteCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Cells.AutoFilter
.Columns(UnwantedColumn).EntireColumn.Hidden = False
End With
Application.ScreenUpdating = True

End Sub

回答No.7

piroin654

No5のSQL文でF14とするところがF4になっていたので、
それも含めて少し修正と追加します。

Private Sub CommandButton1_Click()
　　Const adOpenKeyset = 1
　　Const adLockReadOnly = 1

　　Dim cn As Object
　　Dim rs As Object
　　Dim strSQL As String
　　Dim partSQL As String
　　Dim sDay As Date
　　Dim eDay As Date
　　Dim targetDay As String "Sheet1の日付が入力されている列

　　Set cn = CreateObject("ADODB.Connection")
　　Set rs = CreateObject("ADODB.Recordset")
　　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　　cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO"
　　cn.Open ThisWorkbook.Path & "\myBook.xls"

　　'以下の期間設定に日付はどちらが早い日付でもかまいません
　　'質問のSheet2に期間を入力する場合
　　sDay = CDate(Sheets("sheet2").Cells(2, "A").Value)
　　eDay = CDate(Sheets("sheet2").Cells(2, "B").Value)
　　'日付が入力されている列の設定
　　targetDay = "F14"
　　''フォームにTextBox1とTextBox2をおいてそれぞれに抽出する期間を入力する場合
　　'sDay = CDate(TextBox1)
　　'eDay = CDate(TextBox2)

　　'不要な列はNULLに設定
　　partSQL = "F1,F2,F3,F4,F5,F6,F7,F8=NULL,F9=NULL,F10=NULL,F11=NULL,F12=NULL,F13=NULL,F14"
　　''もし、不要な列は空列として表示しない、ということであれば、以下を使用
　　''この場合は列のＡ，Ｂなどがずれます。
　　'partSQL = "F1,F2,F3,F4,F5,F6,F7,F14"
　　strSQL = "select " & partSQL & " from [Sheet1$] where " & targetDay & " between #" & sDay & "# and #" & eDay & "#"
　　rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
　　Sheet2.Cells(7, 1).CopyFromRecordset rs

'締めくくりの行儀作法
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
　'データのない列を非表示にする場合は以下を使用
　'Call cmdA
End Syb

Private Sub cmdB()
Dim i As Long
For i = 8 To 13
Sheet2.Columns(i).Hidden = True
Next i
End Sub

回答No.6

real beatin（@realbeatin）

こんにちは。お邪魔します。

ご提示のサンプルについて、
> Ａ　 Ｂ　　Ｃ　　Ｄ　　Ｅ　　Ｆ　　Ｇ　　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　 Ｎ
というのはフィールドのタイトルを抽象化した意味として、
つまり１行めは項目タイトル行である、という解釈でお応えします。

今回の課題については、Excel VBA ならではの方法として、
[フィルター]の[詳細設定]＝ＶＢＡでは range.AdvancedFilter メソッド
を活用した方法を紹介します。
[フィルター]の[詳細設定]は、Excelの一般機能ですから、
詳しくないようでしたら、お浚いしてみてください。
もし、全体の設計を[フィルター]の[詳細設定]使用を前提に備えておくことが可能なら、
抽出条件数式（２セル）、テーブルのコピー先、などの作業セルを事前に準備しておけば、
マクロをより簡単なものにすることができます。
[フィルター]の[詳細設定]を使って抽出することのメリットとして、
「開始日付」「終了日付」の一方を省略した「以前」「以後」の抽出も容易になります。

尚、お求めの結果に対するこちらの理解が至っていない場合もありますので、
うまく行かない場合や、疑問が残る場合などは、補足欄にでも書いてみて下さい。
内容的には、Excel/ＶＢＡともに初級の内容の組み合わせですので、
特に説明は書きませんが、必要ならお尋ねくださいませ。

> フォームボタン（例：抽出）
を右クリック→[マクロの登録]にて、以下のマクロを登録して試してみて下さい。

因みに、以下のマクロは
「オートフィルターを使って抽出された状態」
ではうまく機能しませんので、
Sheet1、Sheet2、ともに、
オートフィルターを解除するか、オートフィルター[クリア]した状態で実行してください。
勿論、オートフィルター解除等のオプションを追加することは可能ですが、
以下の処理を組み込む場合は、オートフィルターは不要になりますのので、
とりあえず対策は省きます。

' ' ///

Sub 抽出マクロ()　'　8998854w
Dim rTable As Range
Dim sFml As String
Dim nLastRow1 As Long, nLastRow2 As Long
　　With Sheets("Sheet1")
　　　　nLastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　Set rTable = .Range("(A:G,N:N) 1:" & nLastRow1)
　　End With
　　With Sheets("SHeet2")
　　　　nLastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　If nLastRow2 >= 7 Then .Range("A7:H" & nLastRow2).ClearContents
　　　　rTable.Copy Destination:=.Cells(7, "A")
　　　　Set rTable = Nothing
　　　　If Not IsDate(Cells(2, "B")) Then
　　　　　　.Cells(nLastRow1 + 8, "A").Formula = "=H8>=$A$2"
　　　　Else
　　　　　　.Cells(nLastRow1 + 8, "A").Formula = "=(H8>=$A$2)*(H8<=$B$2)"
　　　　End If
　　　　.Range("A7:H" & nLastRow1 + 7).AdvancedFilter _
　　　　　　Action:=xlFilterCopy, _
　　　　　　CriteriaRange:=.Cells(nLastRow1 + 7, "A").Resize(2), _
　　　　　　CopyToRange:=.Cells(nLastRow1 + 9, "A"), _
　　　　　　Unique:=False
　　　　.Cells(nLastRow1 + 9, "A").Resize(nLastRow1 * 2 + 1, 8).Copy .Cells(7, "A")
　　End With
End Sub

' ' ///

回答No.5

piroin654

連投ですが、ついでなので。
No1で述べたADOを使ったSQL文によるデータの取得方法を。
一応、2007以降のバージョンということで。
一応、日付の取得はシート上のものと、フォームのテキストボックスに
入力するタイプの二つを上げておきました。都合にあわせてどちらかを。

コーディング量は少なくなりますが、ほとんどExcelでは用の無いような
SQLを使っていますが、実際にはサーバーなどからデータを取り込んだり、
あるいは、コーディング量の削減や、ループ処理の回避などに結構使います。

Private Sub CommandButton1_Click()
　　Const adOpenKeyset = 1
　　Const adLockReadOnly = 1

　　Dim cn As Object
　　Dim rs As Object
　　Dim strSQL As String
　　Dim partSQL As String
　　Dim sDay As Date
　　Dim eDay As Date

　　Set cn = CreateObject("ADODB.Connection")
　　Set rs = CreateObject("ADODB.Recordset")
　　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　　cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO"
　　cn.Open ThisWorkbook.Path & "\myBook.xls"

　　'以下の期間設定に日付はどちらが早い日付でもかまいません
　　'質問のSheet2に期間を入力する場合はこちらを使用
　　sDay = CDate(Sheets("sheet2").Cells(2, "A").Value)
　　eDay = CDate(Sheets("sheet2").Cells(2, "B").Value)
　　''フォームにTextBox1とTextBox2をおいてそれ抽出する期間を入力する場合はこちらを使用
　　'sDay = CDate(TextBox1)
　　'eDay = CDate(TextBox2)

　　'不要な列はNULLに設定
　　partSQL = "F1,F2,F3,F4,F5,F6,F7,F8=NULL,F9=NULL,F10=NULL,F11=NULL,F12=NULL,F13=NULL,F14"
　　''もし、不要な列は空列として表示しない、ということであれば、以下を使用
　　'partSQL = "F1,F2,F3,F4,F5,F6,F7,F14"
　　strSQL = "select " & partSQL & " from [Sheet1$] where F4 between #" & sDay & "# and #" & eDay & "#"
　　rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
　　Sheet2.Cells(7, 1).CopyFromRecordset rs

'締めくくりの行儀作法
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
End Syb

わからないところがあれば補足してください。

回答No.4

piroin654

Shhet2への表示で少し訂正。
データは行を詰めて表示します。
No1では行間が空いていました。
変数Lを追加してカウントで行に移動します。

Private Sub CommandButton1_Click()
Dim i As Long
Dim k As Long
Dim L as Long
Dim wk As Workbook

Set wk = ThisWorkbook
i = wk.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
L = 7
For k = 1 To i
'フォームにTextBox1とTextBox2をおいてそれぞれに抽出する期間を入力する場合
'If CDate(wk.Sheets("sheet1").Cells(k, "N").Value) >= CDate(TextBox1) And CDate(wk.Sheets("sheet1").Cells(k, "N").Value) <= CDate(TextBox2) Then
'質問のSheet2に期間を入力する場合
If CDate(wk.Sheets("sheet1").Cells(k, "N").Value) >= CDate(wk.Sheets("sheet2").Cells(2, "A").Value) And CDate(wk.Sheets("sheet1").Cells(k, "N").Value) <= CDate(wk.Sheets("sheet2").Cells(2, "B").Value) Then

wk.Sheets("sheet2").Cells(L, "A").Value = wk.Sheets("sheet1").Cells(k, "A").Value
wk.Sheets("sheet2").Cells(L, "B").Value = wk.Sheets("sheet1").Cells(k, "B").Value
wk.Sheets("sheet2").Cells(L, "C").Value = wk.Sheets("sheet1").Cells(k, "C").Value
wk.Sheets("sheet2").Cells(L, "D").Value = wk.Sheets("sheet1").Cells(k, "D").Value
wk.Sheets("sheet2").Cells(L, "E").Value = wk.Sheets("sheet1").Cells(k, "E").Value
wk.Sheets("sheet2").Cells(L, "F").Value = wk.Sheets("sheet1").Cells(k, "F").Value
wk.Sheets("sheet2").Cells(L, "G").Value = wk.Sheets("sheet1").Cells(k, "G").Value
wk.Sheets("sheet2").Cells(L, "N").Value = wk.Sheets("sheet1").Cells(k, "N").Value
L = L + 1
End If
Next k
End Sub

エラー処理も何もしていない素のままです。

回答No.2

piroin654

No1です。
字句の解釈の問題ですが、
「A2列」とか「B2列」ではなく、「A2」、「B2」ですよね？
もしかしたら、「A2」以下、「B2」以下にずらーっと、
ということですかね。そうであれば少し質問の内容の
解釈を変更しなくてはいけませんが。

回答No.1

piroin654

なぜ回答する人がいないの？

ADOなり、DAOでSQL文を使ってデータを取得する方法もありますが、
あっさりとVBAで泥臭く。
「A7」以下って「A7」からでいいのですかね。
「A8」からならば、以下のコードの「k+6」のところをすべて「k+7」にしてください。

Private Sub CommandButton1_Click()
Dim i As Long
Dim k As Long
Dim wk As Workbook

Set wk = ThisWorkbook
i = wk.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To i
'フォームにTextBox1とTextBox2をおいてそれぞれに抽出する期間を入力する場合
'If CDate(wk.Sheets("sheet1").Cells(k, "N").Value) >= CDate(TextBox1) And
CDate(wk.Sheets("sheet1").Cells(k, "N").Value) <= CDate(TextBox2) Then
'質問のSheet2に期間を入力する場合
If CDate(wk.Sheets("sheet1").Cells(k, "N").Value) >= CDate(wk.Sheets("sheet2").Cells(2, "A").Value) And CDate(wk.Sheets("sheet1").Cells(k, "N").Value) <= CDate(wk.Sheets("sheet2").Cells(2, "B").Value) Then

wk.Sheets("sheet2").Cells(k+6, "A").Value = wk.Sheets("sheet1").Cells(k, "A").Value
wk.Sheets("sheet2").Cells(k+6, "B").Value = wk.Sheets("sheet1").Cells(k, "B").Value
wk.Sheets("sheet2").Cells(k+6, "C").Value = wk.Sheets("sheet1").Cells(k, "C").Value
wk.Sheets("sheet2").Cells(k+6, "D").Value = wk.Sheets("sheet1").Cells(k, "D").Value
wk.Sheets("sheet2").Cells(k+6, "E").Value = wk.Sheets("sheet1").Cells(k, "E").Value
wk.Sheets("sheet2").Cells(k+6, "F").Value = wk.Sheets("sheet1").Cells(k, "F").Value
wk.Sheets("sheet2").Cells(k+6, "G").Value = wk.Sheets("sheet1").Cells(k, "G").Value
wk.Sheets("sheet2").Cells(k+6, "N").Value = wk.Sheets("sheet1").Cells(k, "N").Value
End If
Next k
End Sub

コードが長くなったので崩れていたら補正してください。