Sheet1のデータを条件で行ごと抽出するVBA

質問

ExcelのVBAについて質問です。

Sheet1
　｜　A　｜　B　｜　　C　　|　 D　｜　E
1｜ 5/12｜青森｜出荷済｜11個｜りんご
2｜ 5/12｜静岡｜準備中｜10缶｜お茶
3｜ 5/12｜愛媛｜未出荷｜21個｜みかん
4｜ 5/12｜新潟｜未出荷｜99粒｜おこめ
5｜ 5/12｜栃木｜出荷済｜15個｜巨峰

こんなシートがあります。
これを、シート状のボタンをクリックしたときに、
「C列が"出荷済"または"準備中"の行だけ抽出して、列を入れ替えながらSheet２に並べる」
というVBAを組みたいです。

ボタンを押した後Sheet２がこんな感じになるようにしたいです。

Sheet2
　｜　A　　｜　B　｜　C　|　 D　｜　E
1｜りんご｜11個｜5/12｜青森｜出荷済
2｜お茶　｜10缶｜5/12｜静岡｜準備中
5｜巨峰　｜15個｜5/12｜栃木｜出荷済

列の入れ替えはこのような感じです
（Sheet1⇒Sheet2）
E列⇒A列
D列⇒B列
A列⇒C列
B列⇒D列
C列⇒E列

行はSheer1の順番をSheet２でも抽出されない行を詰める形で維持したいです。
また、ボタンを押されるたびSheet2が全て上書きされる形で構いません。

抽出と入れ替えのヒントだけでもお教え頂ければ自分でやってみたいと思います。
よろしくお願いいたします。

回答No.5

keithin

＞抽出と入れ替えのヒント

オートフィルタで抽出します。
このため，ご質問に書かれているようにではなく（通常はそうするように）１行目は「タイトル行」として，２行目からデータを記入していきます。

オートフィルタで絞り込んだ状態で，
Ｅ列を丸ごと選んでコピーし，そのまま抽出先シートのＡ列（Ａ１セル）にただ貼り付けます
Ｄ列を丸ごとコピーしてＢ列に貼り付けます
Ａ：Ｃ列を丸ごとコピーしてＣ：Ｅ列に(C1セルを選んで）貼ります
一行一行調べて転記していくような，効率の悪いマネはしないようにします。
あと一連の作業の前に，貼り付け先のシート２の全セルを選んでDeleteしておく必要がありますね。
最後にオートフィルタを解除して元の状態に戻して終了です。

以上の手順を「新しいマクロの記録」で記録して作成したマクロなら，ほぼ何の手入れも無しにそのまま利用できます。

回答No.4

tom04

No.3です！
たびたびごめんなさい。

前回のコードは各Sheet2行目以降を操作するコードです。
（通常、1行目にはタイトル行が入ると思いますので・・・）

参考程度にしてください。m(__)m

回答No.3

tom04

こんばんは！
一例です。

Sheet1にコマンドボタンを配置したとして・・・

Private Sub CommandButton1_Click()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
j = ws2.Cells(Rows.Count, 1).End(xlUp).Row
If j > 1 Then
ws2.Rows(2 & ":" & j).ClearContents
End If
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 3) = "出荷済" Or ws1.Cells(i, 3) = "準備中" Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 5)
.Offset(, 1) = ws1.Cells(i, 4)
With .Offset(, 2)
.Value = ws1.Cells(i, 1)
.NumberFormatLocal = "m/d"
End With
.Offset(, 3) = ws1.Cells(i, 2)
.Offset(, 4) = ws1.Cells(i, 3)
End With
End If
Next i
End Sub

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

回答No.2

kmetu

Sub test()
Sheets(1).Activate
mRow = 1
Selection.AutoFilter Field:=3, Criteria1:="=出荷済", Operator:=xlOr, _
Criteria2:="=準備中"
For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
With Sheets(2)
.Range("A" & mRow).Value = Range("E" & c.Row).Value
.Range("B" & mRow).Value = Range("D" & c.Row).Value
.Range("C" & mRow).Value = Range("A" & c.Row).Value
.Range("D" & mRow).Value = Range("B" & c.Row).Value
.Range("E" & mRow).Value = Range("C" & c.Row).Value
End With
mRow = mRow + 1
Next c
End Sub

でいかがでしょうか。

回答No.1

mu2011

抽出と並びえの一例です。

Worksheets("sheet2").Cells.ClearContents
With Worksheets("sheet2")
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "C") = "出荷済" Or Cells(i, "C") = "準備中" Then
j = j + 1
.Cells(j, "A") = Cells(i, "E").Value
.Cells(j, "B") = Cells(i, "D").Value
.Cells(j, "C") = Cells(i, "A").Value
.Cells(j, "D") = Cells(i, "B").Value
.Cells(j, "E") = Cells(i, "C").Value
End If
Next
End With