EXCEL VBA データを抽出して別シートへ貼り付ける方法

お世話になります。以下の例のように
元のデータを 品名ごとの別シートに 日付順に並べて 貼り付けられるように
したいのですが、どのようにコードを組めばよいかご教授 頂けないでしょうか。



元データsheet
A列 　　　　B列 　　　C列　　　　　D列
日付　　　　 品名　　　　　　　　個数
2/1 　　　　 りんご　　　　　　　50
2/13　　　　 みかん　　　　　　　150
3/22　　　　りんご　　　　　　　75
2/10　　　　りんご　　　　　　　100
3/13　　　　みかん　　　　　　　120


抽出先りんごsheet
A列　　　　　B列　　　　C列　　　　D列
日付　　　　　品名 　　　個数
2/1　　　　　りんご　　　50
2/10　　　　 りんご　　　100
3/22　　　　 りんご　　　75

よろしくお願い致します。

No.1 回答者： GooUserラック 回答日時： 2017/03/10 11:51

貼付先は一度クリアしてから貼付で良いのでしょうか？

この回答へのお礼

早速のご回答ありがとうございます。
貼付先は一度クリアしてから、を希望しております。

お礼日時：2017/03/10 15:40

No.2 回答者： rukuku 回答日時： 2017/03/10 13:50

こんにちは

サンプルソースです（と、言いつつ、"マクロの記録"ですが）。
手順として
1.A1を選択
2.フィルタでB列が”りんご”を抽出
3.Ctrl+Aで選択
4.新しいシートを作成
5.そのまま、ペースト
です。

3番目が、
Range("A1:C6").Select
で記録されていますので、
Cells.Select
に書きなおした方が、汎用性が高まります。

その他の点は、
・実際の使用状況
・使う人のレベル
で異なりますので、補足等してください。

Sub Macro1()
'
' Macro1 Macro
'

'
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$6").AutoFilter Field:=2, Criteria1:="りんご"
Range("A1:C6").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
End Sub

No.3 回答者： ExcelDevTool 回答日時： 2017/03/10 15:51

この回答へのお礼

ありがとうございます、このような回答方式があるとは知りませんでした。
参考にさせて頂きます。

お礼日時：2017/03/10 19:03

No.4 回答者： tatsu99 回答日時： 2017/03/10 16:15

データの貼り付け先は、以下のようになりますが、

元データのA列
↓
抽出先のA列

元データのB列
↓
抽出先のB列

元データのD列
↓
抽出先のC列

抽出先のD列はなにも設定しなくて良いですか？

この回答へのお礼

はい、抽出先のD列はなにも設定しない形を希望しています。

お礼日時：2017/03/10 18:43

No.5 回答者： tom04 回答日時： 2017/03/10 16:36

こんにちは！

一例です。
シート名「元データ」はシート見出しの一番左側にあるとします。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Worksheets("元データ")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("E:E").Insert
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("E1"), unique:=True
For i = 2 To .Cells(Rows.Count, "E").End(xlUp).Row
sN = .Cells(i, "E")
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
myFlg = False
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
.Rows(1).AutoFilter field:=2, Criteria1:=sN
Range(.Cells(1, "A"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Range("C:C").Delete
wS.Move after:=Worksheets(i - 1)
Next i
.Range("E:E").Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

No.6 回答者： tom04 回答日時： 2017/03/10 16:55

No.5です。

投稿後気づきました。
日付順に並び替えが必要でしたね。前回のコードは消去し↓のコードにしてください。
（「★」の行を追加しています）

Sub Sample2()
Dim i As Long, k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Worksheets("元データ")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("E:E").Insert
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("E1"), unique:=True
For i = 2 To .Cells(Rows.Count, "E").End(xlUp).Row
sN = .Cells(i, "E")
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
myFlg = False
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
.Rows(1).AutoFilter field:=2, Criteria1:=sN
Range(.Cells(1, "A"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Range("C:C").Delete
wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes '★
wS.Move after:=Worksheets(i - 1)
Next i
.Range("E:E").Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

どうも失礼しました。m(_ _)m

この回答へのお礼

ご回答ありがとうございます。
VBA を勉強している最中で、まだコードの内容を完全に
把握できない状態なのですが、もしよろしければ
例）にあるように組むことはできますでしょうか？
「りんご」というマクロ実行ボタンを作成して、
りんごを、抽出先りんごsheet　に移すことができれば、、
と目指しております。。

お礼日時：2017/03/10 19:02

No.7 回答者： tom04 回答日時： 2017/03/10 19:43

No.5・6です。

＞「りんご」というマクロ実行ボタンを作成して・・・

「元データ」シートにコマンドボタンを挿入しているとします。

Private Sub CommandButton1_Click()
Dim k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
With Worksheets("元データ")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
sN = "りんご"
.Rows(1).AutoFilter , field:=2, Criteria1:="りんご"
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
.Range(Cells(1, "A"), Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Range("C:C").Delete
wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes
.AutoFilterMode = False
Else
MsgBox "該当データなし"
End If
End With
End Sub

こういう感じで良いのでしょうか？m(_ _)m

この回答へのお礼

tomo04様
ご回答ありがとうございました。
また御礼が遅くなり大変申し訳ありませんでした。
頂きましたコードですと、みかん等も一緒に移動して
しまうのですが、これを元に立て直してみたいと思います。
ありがとうございました。

お礼日時：2017/03/13 09:17

No.8 ベストアンサー 回答者： ママチャリ 回答日時： 2017/03/11 09:30

VBA勉強中と云うことなので、「こんな方法もあるよ」的な回答をさせていただきます。

抽出元を抽出先にコピーして、そこから「りんご」以外を削除するロジックとなっています。
なお、抽出先のシートが存在していないとエラーになります。また、抽出対象の「りんご」が無い場合も、エラーになりますので、必要であれば、notimeさんの方で組み込んでください（勉強の一環として）。

Sub りんご()
Dim ToWs As Worksheet
Dim DifRng As Range
Set ToWs = Worksheets("抽出先りんごsheet")
Worksheets("元データsheet").Columns("A:D").Copy Destination:=ToWs.Columns("A:D")
ToWs.Columns("C").Delete
With ToWs.Range("B2:B" & Rows.Count)
Set DifRng = .Find(What:="りんご", LookIn:=xlFormulas, LookAt:=xlPart)
.ColumnDifferences(DifRng).EntireRow.Delete
End With
ToWs.Range("A:C").Sort key1:=ToWs.Range("A1"), order1:=xlAscending, Header:=xlYes
End Sub

この回答へのお礼

ママチャリ様
ご回答ありがとうございました。
非常に参考になりました。
うまくいきました、ありがとうございました。

お礼日時：2017/03/13 09:20