VBA 複数条件でデータを抽出する場合

質問

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

Ａ　 Ｂ　Ｃ　　Ｄ　　Ｅ　　 Ｆ　　Ｇ　　Ｈ　Ｉ　Ｊ　 ＢＳ
1　○○様　○○　 2名 　車　 　可 埼玉 *** *** *** 2015/7/1
2　○○様　××　 3名　 車　 不可 東京 2015/8/1
3　○○様　■■　 2名　 電車　不可　愛知 2015/8/12
4　○○様　□□　 4名　 バス　 可　 新潟 2015/7/13
5　○○様　○×　 3名　 バス　 可　 宮城 2015/6/1
6　○○様　■□　 4名　 車　 不可　東京 2015/8/21
7　○○様　□○　 2名　 バス　 可　 山梨 2015/8/7

「sheet1」のデータでBS列の期間（YYYY/MM/DD～YYYY/MM/DD）とG列の地域名（例：東京）を抽出条件とし、
抽出された結果のsheet1のA列～G列、BS列のみ（H列～BT列は不要）をSheet2のA11以下へ表示するマクロを組みたいと考えています。

Ａ　 Ｂ　 Ｃ　　Ｄ　 Ｅ 　 Ｆ　 Ｇ　　　ＢＳ
2　○○様　××　 3名　 車　 不可 東京 2015/8/1
6　○○様　■□　 4名　 車　 不可　東京 2015/8/21

複数条件下の抽出の場合、どのようなVBAのコードを使用すれば良いでしょうか。

宜しくお願いします。

回答No.4

Prome_Lin

鈍くさいプログラムです。

変数「p(lace)」に場所を設定し、変数「x」に最初の日付、「y」に最後の日付を設定します。

すると、条件に適合したものを「シート２」に出力します。

ご質問の複数条件での抽出は、この場合

If (z >= x And z <= y) And p = Worksheets(1).Cells(i, 7).Value Then

の部分ですが、最初の２つを（）でくくることによって、一つのまとまりにしています。

「And」は、もちろん「かつ」ですから、｛「z >= かつ z<=y」かつ「p = ～」｝です。

最初の「」の部分が１つの条件として認識されています。

今回の場合は、すべて「かつ」ですので、（）がなくても、正常に動くかも知れませんが、意味を考えると（）をつけるべきでしょう。

これが「z = 1 or z = 9」and「p = 0」のような場合ですと、必ず

If (z = 1 Or z = 9) And p = 0 Then

というように、前の部分を（）でくくっておかなければなりません。

Sub CalDay()
Dim c, i, j As Integer
Dim p As String
Dim x, y, z As Date
p = "東京"
x = #8/1/2015#
y = #8/31/2015#
c = 10
For i = 1 To Range("A1").End(xlDown).Row
z = Worksheets(1).Cells(i, 8).Value
If (z >= x And z <= y) And p = Worksheets(1).Cells(i, 7).Value Then
c = c + 1
For j = 1 To 7
Worksheets(2).Cells(c, j).Value = Worksheets(1).Cells(i, j).Value
Next j
Worksheets(2).Cells(c, 8).Value = Worksheets(1).Cells(i, 8).Value
End If
Next i
End Sub

回答No.3

kagakusuki

まず前提条件として、Sheet1において2行目の所に「氏名」や「人数」、「地域」、「日付」等々の各列の項目名が入力されていて、実際のデータは3行目以下に入力されているものとします。(下の添付画像を参照の事)

　その場合、下記の様なVBAは如何でしょうか。

Sub QNo9092443_VBA_複数条件でデータを抽出する場合()

Const OrigSheetName = "Sheet1" '元データシートのシート名
Const PasteSheetName = "Sheet2" '抽出結果の出力先シートのシート名
Const ItemRow = 2 '元データシートにおいて項目名欄と使用している行
Const FirstColumn = "A" '元データの抽出対象範囲の中で最も左端の列
Const LastColumn = "BS" '元データの抽出対象範囲の中で最も右端の列
Const UnnecessaryColumns = "H:BR" '元データシートの中で抽出しない列
Const SearchColumn1 = "G" '地域(都道府県)が入力されている列
Const SearchColumn2 = "BS" '日付が入力されている列
Const PasteCell = "A2" '抽出結果の出力先シートにおいて表の左上の隅となるセル

Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _
LastRow As Long, Region As Variant, Period(1, 1) As Variant, _
temp As Variant, i As Long, c As Range

Period(0, 0) = "1905/1/1"
Period(1, 0) = "9999/12/31"
Period(0, 1) = "以降"
Period(1, 1) = "以前"

If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set OrigSheet = Sheets(OrigSheetName)

If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then
MsgBox "データの転記先のシートとして設定されている" _
& vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set PasteSheet = Sheets(PasteSheetName)

With OrigSheet
LastRow = .Range(LastColumn & Rows.Count).End(xlUp).row
With .Range(LastColumn & Rows.Count).End(xlUp)
If LastRow > .row Then LastRow = .row
End With
If LastRow <= ItemRow Then GoTo label9

label1:
Region = Application.InputBox("地域指定", SearchColumn2 & _
"列に入力されている地域の中で、抽出条件とする地域を入力して下さい", _
, Type:=6)
If Region = vbNullString Or Region = False Then
temp = MsgBox("地域が入力されていません。" & vbCrLf _
& "地域の入力をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:地域の入力をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "地域未入力")
If temp = vbNo Then
Exit Sub
Else
GoTo label1
End If
End If

For i = 0 To 1
label2:
Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _
"列に入力されている日付が西暦何年何月何日! & Period(i, 1)" _
& "のデーターを抽出すれば良いのかを指定して下さい。", _
Period(i, 0), Type:=2)
If Period(i, 0) = vbNullString Or Period(i, 0) = False Then
temp = MsgBox("日付が入力されていません。" & vbCrLf _
& "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:日付の入力をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "日付未入力")
If temp = vbNo Then
Exit Sub
Else
GoTo label2
End If
End If
If IsDate(Period(i, 0)) Then
If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _
Then GoTo label3
End If
temp = MsgBox("入力された値は日付として扱う事が出来ません。" _
& vbCrLf & "日付の入力をやり直して下さい。", _
vbOKOnly + vbExclamation, "入力値不適切")
GoTo label2
label3:
Period(i, 0) = DateValue(Period(i, 0))
Next i
End With

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

With OrigSheet
.Columns(UnnecessaryColumns).Hidden = True
With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow)
.AutoFilter Field:=1, Criteria1:=Region
.AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _
Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0)
End With
Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow)
i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count
End With
If i > 1 Then
With PasteSheet
.Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear
c.SpecialCells(xlCellTypeVisible).Copy
With .Range(PasteCell)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.PasteSpecial Paste:=xlPasteFormats
End With
End With
End If
With c.EntireColumn
.AutoFilter
.Hidden = False
End With

If i > 1 Then GoTo labelE

label9:
MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _
& "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i

labelE:
With Application
.CutCopyMode = False
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

回答No.2

Chiquilin

> どのようなVBAのコードを使用すれば良いでしょうか。
VBAの知識はあるのでしょうか。どのようなと書いてますが マクロは自分
で作るものです。どっかに用意されている訳じゃありません。知識がない
ならマクロは止めておいた方がいいと思います。

フィルタの詳細設定を使えば 条件を指定してデータを抽出することはでき
ますから それを記録マクロにすることから始めてみたらどうでしょう。

回答No.1

ushi2015

こんにちは
1行目に項目行は無いのですか？
項目行が有れば、抽出条件をシート上に設定して、フィルタオプションで抽出
する作業をマクロに記録するだけでコードが出来上がると思います。