Excel VBAでオートフィルタで抽出した列データを別シートの最終行にコピーするには

添付図を参照してください。
元データがある表（シート名：統計）へ（シート名：Sheet1）にあるオートフィルタで抽出したデータを統計 シートの最終行を判断して、Sheet1のA列とD列の該当のデータのみをコピーして
シートの最終行から貼り付けをするマクロを作成したいです。
最終行を判断するには、
Range(Selection, Selection.End(xlDown)).Select　など記述すべきかと思いますが、
あくまでSheet1の抽出したデータ行は15行までではなくデータにより様々な行数を取得するようにしたいです。Range("A2", Range("A2").End(xlDown)).Select　など？

すいませんが、ご教授頂きますようお願いいたします。

質問者からの補足コメント

• 

  たびたびすいません、該当のデータをコピーした後、コピーした行まで罫線を引いておく
  事もしたいのですができますでしょうか？（B、C、E行も）

    補足日時：2016/06/03 00:41

No.3 ベストアンサー 回答者： tom04 回答日時： 2016/06/03 16:13

No.1です。

＞ちなみにオートフィルタでC列”教科”を算数、E列”ランク”をAを組み込む場合は・・・

コード内に"教科"と"ランク"を組み込んでしまうと汎用性がなくなると思いますので、
インプットボックスで"教科"と"ランク"を入力するようにしてみました。

Sub Sample2()
Dim lastRow As Long, wS As Worksheet, myRng As Range
Dim Kyouka As String, myRnk As String
Set wS = Worksheets("統計")
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set myRng = Range(.Cells(2, "A"), .Cells(lastRow, "E"))
Kyouka = Application.InputBox("フィルタを掛ける教科を入力")
myRnk = Application.InputBox("フィルタを掛けるランクを入力")
With .Range("A1")
.AutoFilter field:=3, Criteria1:=Kyouka
.AutoFilter field:=5, Criteria1:=myRnk
End With
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
myRng.SpecialCells(xlCellTypeVisible).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
wS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End If
.AutoFilterMode = False
End With
End Sub

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

この回答へのお礼

素晴らしい、この内容で奇麗に貼り付けれる事を確認いたしました。
ちなみにIf .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then～で
"Sheet1"シートのA行から"統計"シートのA行へ該当のデータをコピーしていますが、仮に"Sheet1"シートのA行から"統計"シートのB行へコピー、"Sheet1"シートのD行から"統計"シートのF行へと指定した行へコピーする事もできるのでしょうか？この場合は、記述がまた変わってくるのでしょうか？（追加になるかもしれませんが申し訳ございません、これで解消できると思います）

お礼日時：2016/06/05 17:08

No.4 回答者： tom04 回答日時： 2016/06/05 20:09

No.1・3です。

＞仮に"Sheet1"シートのA行から"統計"シートのB行へコピー、"Sheet1"シートのD行から"統計"シートのF行へ・・・

「Sheet1」のA列を「統計Sheet」の最終行1行下のB列に、
「Sheet1」のD列を「統計Sheet」の最終行1行下のF列のにそれぞれコピー＆ペーストする！という意味でしょうか？

そうであれば当然コードそのものが変わってきます。

Sub Sample3()
Dim j As Long, lastRow As Long, maxRow As Long, wS As Worksheet
Dim Kyouka As String, myRnk As String
Set wS = Worksheets("統計")
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Kyouka = Application.InputBox("フィルタを掛ける教科を入力")
myRnk = Application.InputBox("フィルタを掛けるランクを入力")
With .Range("A1")
.AutoFilter field:=3, Criteria1:=Kyouka
.AutoFilter field:=5, Criteria1:=myRnk
End With
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
maxRow = wS.UsedRange.Rows.Count + 1
Range(.Cells(2, "A"), .Cells(lastRow, "A")).Copy wS.Cells(maxRow, "B")
Range(.Cells(2, "D"), .Cells(lastRow, "D")).Copy wS.Cells(maxRow, "F")
wS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End If
.AutoFilterMode = False
End With
End Sub

こんな感じになると思います。
ただ、「統計」Sheetの貼り付ける列を変えてしまうと、項目が異なる列に貼り付けることになるので
データとしては全く意味がないものになるような気がするのですが・・・m(_ _)m

この回答へのお礼

早速のご回答ありがとうございます！その通りです！　なるほど、こういうコードにすれば違った列にコピーができるのですね。　”統計”シートにそもそも”Sheet1"シートと同じじゃないケースはどうするのかこれで解消できました。大変助かり感謝しております。ありがとうございました！

お礼日時：2016/06/05 21:42

No.2 回答者： ママチャリ 回答日時： 2016/06/02 22:18

フィルタがかかっていれば、普通のコピーで可視行だけコピーできますよ。

こんな感じです。

Sub sample()
Dim FromRow As Long
Dim ToRow As Long
FromRow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
ToRow = Worksheets("統計").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet1").Range("A2:A" & FromRow).Copy _
Destination:=Worksheets("統計").Range("A" & ToRow)
Sheets("Sheet1").Range("D2:D" & FromRow).Copy _
Destination:=Worksheets("統計").Range("D" & ToRow)
End Sub

この回答へのお礼

なるほど、こちらでも実現可能みたいです。他の方の補足にあるように、オートフィルタでC列”教科”を算数、E列”ランク”をAを組み込む場合は、また違ってくるのでしょうか？

お礼日時：2016/06/02 23:59

No.1 回答者： tom04 回答日時： 2016/06/02 22:00

こんばんは！

「統計」Sheetに貼りつけるのは、A列とD列だけで良いのですね？
一例です。標準モジュールにしてください。

Sub Sample1()
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("統計")
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If .FilterMode Then
Range(.Cells(2, "A"), .Cells(lastRow, "A")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Range(.Cells(2, "D"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(Rows.Count, "D").End(xlUp).Offset(1)
Else
MsgBox "絞り込まれていません"
End If
End With
End Sub

※　とりあえずオートフィルタで絞り込まれている場合のみ
コピー＆ペーストするようにしてみました。m(_ _)m

この回答へのお礼

さすがです、これでできそうです。
ちなみにオートフィルタでC列”教科”を算数、E列”ランク”をAを組み込む場合は、どのような記述を追加すればよいのでしょうか？　また違ってきますか？

お礼日時：2016/06/03 00:01