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

Question

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

tom04 · Accepted Answer

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

tom04 · Answer

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

ママチャリ · Answer

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

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

tom04 · Answer

こんばんは！

「統計」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

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

No.1です。

No.1・3です。

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

こんばんは！

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング