EXCELでデータを条件わけして抽出する方法はありますか？

質問

EXCELでデータを条件分けして抽出する方法はありますか？

EXCELでsheet1の元データから、条件を検索して、 sheet2とsheet3に移動させたいです。

sheet 1（元データ）
　　Ａ 　Ｂ 　Ｃ 　Ｄ
2 日付 名前 作業 時間
3 8/1 　鈴木 1 1.0
4 8/1 　佐藤 1 　1.5
5 8/1 　藤原 1　 2.0
6 8/2 鈴木 2 1.0
7 8/4 佐藤 2 1.0
8 8/4 鈴木 3 2.5
9 8/5 鈴木 4 1.0
10 8/5 藤原 4 4.0

sheet2 （新規データ）
　Ａ 　　Ｂ 　Ｃ 　Ｄ
2 日付 名前 作業 時間
3 8/1 鈴木 1 1.0
4 8/1 藤原 1 2.0
5 8/2 鈴木 2 1.0
6 8/4 鈴木 3 2.5
7 8/5 鈴木 4　 1.0
8　8/1　藤原 4　 4.0

sheet3
　　Ａ　 Ｂ　 Ｃ　 Ｄ
2 日付 名前 作業 時間
3　8/1 佐藤　1 　1.5
4　8/4 佐藤　2 　1.0

・ sheet1での検索条件は、・作業4があるときは、『名前』が同じ人のデータ（作業1.2.3.4）を sheet2に移動させる（例でいくと鈴木さんは、作業1.2.3.4それぞれある)
・この時、作業1,4の人も移動させる（例でいくと藤原さんは1,4のみ)
・sheet3は、sheet2で移動しなかった人→つまり、『作業4』がない人のみ移動
・人は必ず１度しかでてこないです。結果、『作業4』は必ず同じ人には1回のみです。

私が考えたところ、
１.『作業4』がある人を先にsheet2に移動させて、sheet2で同じ人をsheet2に抽出する
2.sheet3に『作業4』がない人を抽出する
のやり方でできるとおもうのですが、やり方がわかりません。

できれば簡単なマクロがいいです。説明が不十分でわかりにくいこともあるとおもいますが、よろしくお願いします

回答No.7

merlionXX

merlionXXです。
すみません、まだミスがありました。
今度は大丈夫だと思います。

Sub test05()

Dim i As Long, j As Long, n As Long, x As Long, y As Long '変数宣言
Dim nmRng As Range, nm As Range
Dim myAr, myRw(2 To 3) As Long
Dim myDic As Object

Set myDic = CreateObject("Scripting.Dictionary")

For i = 2 To 3
Sheets("Sheet" & i).Cells.ClearContents 'Sheet1~2クリア
Sheets("Sheet" & i).Range("A2:D2").Value = Sheets("Sheet1").Range("A2:D2").Value 'Sheet1~2に見出行
myRw(i) = 3
Next i

With Sheets("Sheet1")
Set nmRng = .Range(.Cells(3, "B"), .Cells(3, "B").End(xlDown)) 'リストB列の範囲取得
End With

For Each nm In nmRng
myDic(nm.Value) = myDic(nm.Value) + IIf(nm.Offset(0, 1).Value = 4 Or nm.Offset(0, 1).Value = 5, 1, 0)
Next nm

For Each nm In nmRng
x = IIf(myDic(nm.Value) >= 1, 2, 3) 'itemが1なら（作業4か5なら）
With Sheets("Sheet" & x) 'sheetを選び
.Range(.Cells(myRw(x), "A"), .Cells(myRw(x), "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value '転記
End With
myRw(x) = myRw(x) + 1 '行カウント
Next nm

End Sub

お礼

本当に丁寧にありがとうございます。
仕事の都合上、月曜日に挑戦してみます。
ここまで丁寧にしてくれて本当に感謝でいっぱいです。
できる限りがんばりたいと思います。

補足

たびたびすみません。
先ほど行なってみたところ完璧に
動きました。
本当にありがとうございました。
私も勉強してＶＢＡをしっかり覚えたいと思います。
ありがとうございました。

回答No.6

merlionXX

No5です。
先ほどの回答は一見うまくいったようで実はミスがありました。
修正しました。

Sub test04()

Dim i As Long, j As Long, n As Long, x As Long, y As Long '変数宣言
Dim nmRng As Range, nm As Range
Dim myAr, myRw(2 To 3) As Long
Dim myDic As Object

Set myDic = CreateObject("Scripting.Dictionary")

For i = 2 To 3
Sheets("Sheet" & i).Cells.ClearContents 'Sheet1~2クリア
Sheets("Sheet" & i).Range("A2:D2").Value = Sheets("Sheet1").Range("A2:D2").Value 'Sheet1~2に見出行
myRw(i) = 3
Next i

With Sheets("Sheet1")
Set nmRng = .Range(.Cells(3, "B"), .Cells(3, "B").End(xlDown)) 'リストB列の範囲取得
End With

For Each nm In nmRng
If nm.Offset(0, 1).Value = 4 Or nm.Offset(0, 1).Value = 5 Then '作業4か5なら
y = 1 'itemに1を登録
myDic(nm.Value) = y
End If
Next nm

For Each nm In nmRng
x = IIf(myDic(nm.Value) = 1, 2, 3) 'itemが1なら（作業4か5なら）
With Sheets("Sheet" & x) 'sheetを選び
.Range(.Cells(myRw(x), "A"), .Cells(myRw(x), "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value '転記
End With
myRw(x) = myRw(x) + 1 '行カウント
Next nm

End Sub

回答No.5

merlionXX

No2^3 merlionXXです。
わたしの回答はお好みではなかったようで何のお返事もいただけませんでしたが、作業が5の人も追加したいのですね。
No1さんの回答が洗練されていますのでわたしも見習い、以下のようにしてみました。
ご参考まで。

Sub test03()

Dim i As Long, j As Long, n As Long, x As Long, y As Long '変数宣言
Dim nmRng As Range, nm As Range
Dim myAr, myRw(2 To 3) As Long
Dim myDic As Object

Set myDic = CreateObject("Scripting.Dictionary")

For i = 2 To 3
Sheets("Sheet" & i).Cells.ClearContents 'Sheet1~2クリア
Sheets("Sheet" & i).Range("A2:D2").Value = Sheets("Sheet1").Range("A2:D2").Value 'Sheet1~2に見出行
myRw(i) = 3
Next i

With Sheets("Sheet1")
Set nmRng = .Range(.Cells(3, "B"), .Cells(3, "B").End(xlDown)) 'リストB列の範囲取得
End With

For Each nm In nmRng
If nm.Offset(0, 1).Value = 4 Or nm.Offset(0, 1).Value = 5 Then '作業4か5なら
y = 1 'itemに1を登録
End If
myDic(nm.Value) = y
Next nm

For Each nm In nmRng
x = IIf(myDic(nm.Value) = 1, 2, 3) 'itemが1なら（作業4か5なら）
With Sheets("Sheet" & x) 'sheetを選び
.Range(.Cells(myRw(x), "A"), .Cells(myRw(x), "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value '転記
End With
myRw(x) = myRw(x) + 1 '行カウント
Next nm

End Sub

お礼

素早い返答ありがとうございました。
おかげさまで、うまくいきました。
いきなりマクロを使って、整理してくれとの頼みごとで
とまどいばかりですが、もっと勉強して自分で
解決できるようにがんばりたいとおもいます。
本当に助かりました。ありがとうございました。

回答No.4

imogasi

条件
（１）Ｓｈｅｅｔ１で作業４の氏名を挙げる。
（２）その氏名の人の記録は全部挙げる
Ｓｈｅｅｔ２を
ソート法でやってみました
Sub test01()
Dim s(20)
Dim sh1, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("A65536").End(xlUp).Row
sh1.Range("a2:D" & d).Sort Key1:=sh1.Range("C2"), Key2:=sh1.Range("B2")
k = 2 'Ｓｈｅｅｔ２の先頭行
p = sh1.Range("C:C").Find(sh2.Range("A1")).Row '4の初出行
n = 1
For j = p To p + 100
If sh1.Cells(j, "C") = 4 And j <= d Then
s(n) = sh1.Cells(j, "B") '4のある氏名を配列に
n = n + 1
End If
Next j
'---
For m = 1 To n - 1
MsgBox "作業４" & s(m)
Next m
'---
For i = 2 To d
For m = 1 To n - 1
If sh1.Cells(i, "B") = s(m) Then
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = sh1.Cells(i, "B")
sh2.Cells(k, "C") = sh1.Cells(i, "C")
sh2.Cells(k, "D") = sh1.Cells(i, "D")
k = k + 1
End If
Next m

Next i
End Sub
あとＳｈｅｅｔ２のＡ列の日付設定、並び順は省いています。
Ｓｈｅｅｔ３は略
Ｓｈｅｅｔ１の原データが崩れると困るときはコピー先シートで作業

回答No.3

merlionXX

No2です。
同一人物が作業４を重複した場合を想定していませんでした。
訂正します。

Sub test02()

Dim i As Long, j As Long, n As Long, y As Long '変数宣言
Dim nmRng As Range, nm As Range, lstRng As Range, x As Range
Dim myAr
Dim myDic As Object

Set myDic = CreateObject("Scripting.Dictionary")

With Sheets("Sheet1")
Set nmRng = _
.Range(.Cells(3, "B"), .Cells(3, "B").End(xlDown)) 'リストB列の範囲取得
For Each nm In nmRng
If nm.Offset(0, 1).Value = 4 Then '作業が４ならば
If Not myDic.Exists(nm.Value) Then '重複してなければ
myDic.Add nm.Value, "" '登録
End If
End If
Next nm
End With

myAr = myDic.keys '登録を配列に

With Sheets("Sheet2")
j = 2
For n = LBound(myAr) To UBound(myAr) '配列で
For Each nm In nmRng
If nm.Value = myAr(n) Then '存在すれば
j = j + 1
.Range(.Cells(j, "A"), .Cells(j, "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value 'Sheet2に転記
End If
Next nm
Next n
.Range(.Range("A3:D3"), .Range("A3:D3").End(xlDown)).Sort _
Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo '日付順に並び替え
Set lstRng = _
.Range(.Range("A3:D3"), .Range("A3:D3").End(xlDown)) 'Sheet2の新規データ範囲取得
End With

y = 2
For Each nm In nmRng 'リストB列の各氏名が
Set x = _
lstRng.Columns(2).Find(What:=nm.Value, LookIn:=xlValues, LookAt:=xlWhole) '検索
If x Is Nothing Then '新規データ範囲になければ
y = y + 1
With Sheets("Sheet3")
.Range(.Cells(y, "A"), .Cells(y, "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value 'Sheet3に転記
End With
End If
Next nm

End Sub

回答No.2

merlionXX

お書きのとおり、Sheet1のデータが見出しを除き、A3から下に途中の空白無く並んでいるものとします。
データはA～D列の4列とします。
Sheet2、Sheet3には2行目（A2～D2)に見出し行はあるものとします。

Sub test01()

Dim i As Long, j As Long, n As Long, y As Long '変数宣言
Dim nmRng As Range, nm As Range, lstRng As Range, x As Range
Dim myAr()

With Sheets("Sheet1")
Set nmRng = _
.Range(.Cells(3, "B"), .Cells(3, "B").End(xlDown)) 'リストB列の範囲取得
For Each nm In nmRng
If nm.Offset(0, 1).Value = 4 Then '作業が４ならば
ReDim Preserve myAr(i) '動的配列
myAr(i) = nm.Value '配列に入れる
i = i + 1
End If
Next nm
End With

With Sheets("Sheet2")
j = 2
For n = LBound(myAr) To UBound(myAr) '配列で
For Each nm In nmRng
If nm.Value = myAr(n) Then '存在すれば
j = j + 1
.Range(.Cells(j, "A"), .Cells(j, "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value 'Sheet2に転記
End If
Next nm
Next n
.Range(.Range("A3:D3"), .Range("A3:D3").End(xlDown)).Sort _
Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo '日付順に並び替え
Set lstRng = _
.Range(.Range("A3:D3"), .Range("A3:D3").End(xlDown)) 'Sheet2の新規データ範囲取得
End With

y = 2
For Each nm In nmRng 'リストB列の各氏名が
Set x = _
lstRng.Columns(2).Find(What:=nm.Value, LookIn:=xlValues, LookAt:=xlWhole) '検索
If x Is Nothing Then '新規データ範囲になければ
y = y + 1
With Sheets("Sheet3")
.Range(.Cells(y, "A"), .Cells(y, "D")).Value = _
nm.Offset(0, -1).Resize(, 4).Value 'Sheet3に転記
End With
End If
Next nm

End Sub

回答No.1

fujillin

値のチェックなどは省いていますが、こんな感じでしょうか？
（ご質問文だとデータのスタート行が3行目になっているので、そのまま3行目としています。元データのシートがアクティブシートと仮定。）

方法としては、最初にC列を見て、作業4がある人をディクショナリに登録。
元データの先頭行から順に見て、登録された名前ならSheet2に、そうでなければSheet3にコピーするというものです。

Sub test()
Dim rw As Long, rmax As Long, i As Integer
Dim rn(0 To 1) As Long, sht(0 To 1) As Worksheet
Dim NameDic As Object

Set sht(0) = Worksheets("Sheet2")　 '←作業4のある人用のシート名
Set sht(1) = Worksheets("Sheet3") 　'←残りのリスト用のシート名
Set NameDic = CreateObject("Scripting.Dictionary")

For i = 0 To 1
　sht(i).Cells.ClearContents
　Rows(2).Copy (sht(i).Rows(2))
　rn(i) = 3
Next i

rmax = Cells(Rows.Count, 2).End(xlUp).Row
For rw = 3 To rmax
　If Cells(rw, 3).Value = 4 And Cells(rw, 2) <> "" Then NameDic(Cells(rw, 2).Text) = 4
Next rw

For rw = 3 To rmax
　If NameDic(Cells(rw, 2).Text) = 4 Then i = 0 Else i = 1
　Rows(rw).Copy (sht(i).Rows(rn(i)))
　rn(i) = rn(i) + 1
Next rw
Set NameDic = Nothing
End Sub

お礼

ありがとうございました。
ばっちりうまくいきました。本当にありがとうございました。

補足

たびたびすみません。
解決したと思われたのですが、問題が生じてしまいました。
作業が5の人も追加したいのです。
作業5はシート２（新規データ）の方に追加させたいです。

sheet 1（元データ）
　　Ａ 　Ｂ 　Ｃ 　Ｄ
2 日付 名前 作業 時間
3 8/1 　鈴木 1 1.0
4 8/1 　佐藤 1 　1.5
5 8/1 　藤原 1　 2.0
6 8/2 　鈴木 2 1.0
7 8/4 　佐藤 2 1.0
8 8/4 　鈴木 3 2.5
9 8/5 　鈴木 4 1.0
10 8/5 　藤原 4 4.0
11　8/6　大橋　5　5.0
sheet2 （新規データ）
　Ａ 　　Ｂ 　Ｃ 　Ｄ
2 日付 名前 作業 時間
3 8/1 鈴木 1 1.0
4 8/1 藤原 1 2.0
5 8/2 鈴木 2 1.0
6 8/4 鈴木 3 2.5
7 8/5 鈴木 4　 1.0
8　8/1　藤原 4　 4.0
9　8/6　大橋　5　5.0

というようにしたいです。
自分なりにfujillinさんのマクロを改造したのですが、
おもうように動きません。
どうか、ご教授お願いします。