Excelマクロ 複数条件一致データの抽出方法

質問

お世話になります。

2個の条件に一致するものを別シートに抽出したいのですが、お知恵を貸してください。
Excelシートで下記のような表があります。
これをL列（品名)かつS列(品質)の条件に一致するデータで新しいシートを作成したいのですが、
その際に新しいシート名は"AA1"のようにしたいのです。

条件がC列(品名)だけであれば下記で動いたのですが…。

（データ）
A列　入荷日
I列　 品目コード
L列　品名
S列　品質
V列　在庫
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
1/1・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・20
2/2・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・10
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
2/3・・・・01・・・・・・・BB・・・・・・・・1・・・・・・・・・10
※以下、最大100品目の行数10000程です。
　↓↓
（実行後希望）
シート名 AA1
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
1/1・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・20
2/2・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・10

シート名 AA2
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10

シート名 BB1
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
2/3・・・・01・・・・・・・BB・・・・・・・・1・・・・・・・・・10

Sub Sheet抽出()
Dim i As Long, Lstrow As Long, myName As String
Dim MySht As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Sheets("sheet1")

'準備
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
myName = .Cells(i, 9)

'シートの存在確認
For Each MySht In Worksheets
If MySht.Name = myName Then
myFlg = True '既にシート在り!!
Sheets(myName).Range("a1") _
.CurrentRegion.Offset(1).ClearContents
Exit For
End If
Next

'新規シートの追加
If myFlg = False Then
Worksheets.Add.Name = myName
End If
With Sheets(myName)
.Range("A1") = "入荷日"
.Range("I1") = "品名コード"
.Range("L1") = "品名"
.Range("S1") = "品質"
.Range("V1") = "在庫"

End With
myFlg = False
Next

'データの転記
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
myName = .Cells(i, 9).Value
.Range("A" & i & ":Ｖ" & i).Copy _
Sheets(myName).Cells(Rows.Count, 1).End(xlUp).Offset(1)
With Sheets(myName)
.Activate
Lstrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 21) = ""
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 21) = _
"=SUM(v2:V" & Lstrow & ")"
End With
Next
End With
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End Sub

実行後希望のように抽出するには、どうすれば良いのでしょうか？
よろしくお願いいたします。

回答No.4

tom04 · ベストアンサー

ぎゃっはっはぁ～～！
なかなか解決しませんね。

＞イメージとしてシート2以降の表示は、
＞元データA列→新シートA列（1行目のタイトルも表示）
＞元データI列→新シートB列（〃）
＞元データL列→新シートC列（〃）
＞元データS列→新シートD列（〃）
＞元データV列→新シートE列（〃）

結局元データSheetのA・I・L・S・V列のデータだけを
新規SheetのA～E列に項目行も含めて表示させればよい訳ですよね？

コピー元の範囲と貼り付け先のセル番地だけの問題だと思います。

Sub Sample4()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
'↓★ココから変更
.Cells(1, "B").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
.Cells(1, "J").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("B1")
.Cells(1, "M").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("C1")
.Cells(1, "T").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("D1")
.Cells(1, "W").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("E1")
'↑★ココまで
wS.Name = wS2.Cells(k, "A")
wS.Columns.AutoFit
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub

これで何とかご希望通りになるでしょうか？m(_ _)m

お礼

ありがとうございました！！
おかげで希望通りのものができました。

貴重なお時間を何度も割いて頂き本当にありがとうございました！
m(_ _)m

回答No.3

tom04

続けてお邪魔します。
前回は余計なお世話を焼いてしまったようですね！

＞A~I~L~S~Vの”～”の列は、シート2以降ではタイトルも非表示もしくは最初から表示しないようにはできますでしょうか？

No.2のコードにちょっとだけ手を加えて
1行目はなにもせずに、元データの2行目以降を各Sheetの各列2行目以降に貼り付けてみました。

Sub Sample3()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
.Cells(2, "B").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("A2")
.Cells(2, "J").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("I2")
.Cells(2, "M").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("L2")
.Cells(2, "T").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("S2")
.Cells(2, "W").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("V2")
wS.Name = wS2.Cells(k, "A")
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub

※　各Sheetの1行目は空白セルになると思います。
もし1行目から項目なしの実データを表示したい場合は
各列の貼り付け先セル番地を1行目にしてください。
仮に今回のコードのA列だけでいえば
＞.Cells(2, "B").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("A2")
を
＞ .Cells(2, "B").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")

のように元データの2行目以降を追加したSheetの1行目に変更します。
もちろんA・I・L・S・V列すべてを変更です。

今度はどうでしょうか？m(_ _)m

補足

ご回答ありがとうございますm(__)m
コードを拝見して少しずつ勉強させて頂いております。

tom04先生、すみませんあと1回だけ…。
私の質問表現の仕方が悪くて申し訳ございません。
再度お手間なのですがご教示お願い致します。

イメージとしてシート2以降の表示は、
元データA列→新シートA列（1行目のタイトルも表示）
元データI列→新シートB列（〃）
元データL列→新シートC列（〃）
元データS列→新シートD列（〃）
元データV列→新シートE列（〃）

元データB列→新シートでは表示しない
元データC列→新シートでは表示しない
…

というような感じなのですが、説明が拙くてすみません。
もう少々お知恵をお貸しくださいm(_ _;)m

回答No.2

tom04

No.１です。

＞シート2以降の抽出表示はAISLV列だけにしたい場合
というコトですので、粛々と列を選択するよう変更してみました。

尚、元データと同じ列のA・I・S・L・V列に貼り付けています。
（1行目の項目行は他の列もすべて貼り付けとします）

Sub Sample2()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
.Rows(1).Copy wS.Range("A1")
wS.Range("A1").Delete shift:=xlToLeft
Range(.Cells(1, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
Range(.Cells(1, "J"), .Cells(lastRow, "J")).SpecialCells(xlCellTypeVisible).Copy wS.Range("I1")
Range(.Cells(1, "M"), .Cells(lastRow, "M")).SpecialCells(xlCellTypeVisible).Copy wS.Range("L1")
Range(.Cells(1, "T"), .Cells(lastRow, "T")).SpecialCells(xlCellTypeVisible).Copy wS.Range("S1")
Range(.Cells(1, "W"), .Cells(lastRow, "W")).SpecialCells(xlCellTypeVisible).Copy wS.Range("V1")
wS.Name = wS2.Cells(k, "A")
wS.Columns.AutoFit
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub

※　元データSheetに作業列A列を挿入　→　コピー＆ペースト　→　最後にA列を削除　としていますので、
コピー元がすべて1列ずつ右側にずれています。

今度はどうでしょうか？m(_ _)m

補足

再度の早々のご回答大変ありがとうございます！

こちらも勿論上手く動いてくれているのですが、実は元データのタイトル行がIV列まであるのです‥。
A~I~L~S~Vの”～”の列は、シート2以降ではタイトルも非表示もしくは最初から表示しないようにはできますでしょうか？
すでに初心者の私にはHiddenを組み込めばいいのだろうか…としか思考が追いつかず、度々のお願いで恐縮ですがもう少しの間お知恵をお貸しくださいm(_ _;)m

回答No.1

tom04

こんばんは！
一例です。

元データはSheet見出しの一番左側にあるとします。
＞※以下、最大100品目の行数10000程です
というコトですので10000行をループさせてもいいのですが、時間ばかりかかり
Excelが「応答なし」になる可能性がありますので、フィルタで処理してみました。

標準モジュールです。

Sub Sample1()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData

For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
Range(.Cells(1, "B"), .Cells(lastRow, "W")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Name = wS2.Cells(k, "A")
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub

※　Sheet見出しの一番左側Sheet以外は一旦削除　→　Sheet追加　としていますので
Sheet2やSheet3が存在し、データがある場合はなくなってしまいますので、
別Bookでマクロを試してみてください。m(_ _)m

補足

早いご回答ありがとうございます！
頂いたコード希望通り動きました。

補足で申し訳ないのですが、シート2以降の抽出表示はAISLV列だけにしたい場合、
こちらのコードはどう変更させれば良いでしょうか？
お手数をお掛けしますがよろしくお願いいたします。