EXCEL VBA（For～if）での抽出結果を値のみ貼付する手段について

Question

EXCELのマクロにて、データベースのシートからIFで条件に合った行を抽出し、別シートに結果を貼付ているのですが貼付先のシートの書式を活かしたいため、抽出結果を値のみ貼付をしたいと思っています。
データ量が大きくオートフィルターで行くと動作が重くなるため、少しでも高速に出来るよう添付の通りFor～ifで作りたくいのですが、PasteSpecialのようなことができる方法が分かられる方、ご教授お願いできますでしょうか。

Sub TEST1()
    
    Dim N
    With Worksheets("貼付先")
        For i = 7 To 5006
            'D列が「キャップ」の場合
            If Worksheets("データベース").Cells(i, "B") = "キャップ" Then
                '貼付先のB列を見て最終行を取得
                N = .Cells(Rows.Count, "C").End(xlUp).Row
                '一致したデータのB列から11列分をコピーして最終行の1行下に貼付け
                Worksheets("データベース").Cells(i, "B").Resize(, 17).Copy .Cells(N + 1, "C")
            End If
        Next
    End With
    
End Sub

Answer 1

値のみの貼り付けをしたいということですね。
下記で値のみ貼り付けになります。

                Worksheets("データベース").Cells(i, "B").Resize(, 17).Copy
                .Cells(N + 1, "C").PasteSpecial Paste:=xlPasteValues

あるいは、Value への代入の方が少し高速です。

               .Cells(N + 1, "C").Resize(, 17).Value = Worksheets("データベース").Cells(i, "B").Resize(, 17).Value

ただ、ループで1行ずつ転記していくより、オートフィルターで抽出して１回でコピーした方が高速だと思いますが、遅かったですか。

あと、高速化の定番の画面更新の停止、再計算の停止は試してみましたか。

---

オートフィルターを使ったコード例ですが、下記で遅いですか。

Sub TEST2()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Worksheets("データベース").Range("B6:R5006")
        .AutoFilter Field:=1, Criteria1:="キャップ"
        .Offset(1).Copy
    End With
    
    Worksheets("貼付先").Cells(Rows.Count, "C").End(xlUp).Offset(1).PasteSpecial xlPasteValues
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Comments

[RANDS_CHANP]

さっそくご教授頂き有難うございます。とても嬉しく思います。
画面停止Application.ScreenUpdatingは入れておりますが、VBAが達者で無いため代わりに使用しているシート上の幾つかの関数が重いのだと思います。

元コードの８行目'一致したデータのB列から11列分をコピーして最終行の1行下に貼付け’コメントの下に
一番初めに頂いたコードに置き換えて実施すると２行目（.Cells(N + 1, "C") .PasteSpecial Paste:=xlPasteValues）で止まってしまいます。何故か分からないです。

記載頂いたオートフィルターのほうで実施してみると空白が貼付けられるため、こちらは少し原因
調べてみて改めて結果ご報告させて頂きます。

[RANDS_CHANP]

hatena19様
オートフィルターのほう、当方のセル番地がズレていただけで正常に貼付できました。有難うございます。
ただ、やはりシート上で使っている関数が重いのか、処理は１５～２０sec.くらいかかっています。

２つ目に記載頂いた
　　Worksheets("データベース").Cells(i, "B").Resize(, 17).Copy
.Cells(N + 1, "C").Resize(, 17) .Value = Worksheets("データベース").Cells(i, "B").Resize(, 17).Value
を比べてみたかったのですが、こちらが何故か止まってしまいます。

[RANDS_CHANP]

hatena19様

もし宜しければ、
Worksheets("データベース").Cells(i, "B").Resize(, 17).Copy
.Cells(N + 1, "C").Resize(, 17) .Value = Worksheets("データベース").Cells(i, "B").Resize(, 17).Value
のほう、構文エラーが出るので誤りをご教授頂けると幸いです。

[hatena19]

タイプミスしてました。

.Cells(N + 1, "C") .PasteSpecial Paste:=xlPasteValues

.PasteSpecial の前の半角スペースを削除してください。

.Cells(N + 1, "C").Resize(, 17) .Value = Worksheets("データベース").Cells(i, "B").Resize(, 17).Value

.Value の前の半角スペースを削除してください。

回答の方は修正しておきました。

[RANDS_CHANP]

hatena19様

有難うございます。無事確認できました。比較しましたところほぼ同じですが、仰るように
若干オートフィルターの方が速かったです。
私が元々作成していたオートフィルターの方法より７～８秒早くなりました。
日々使用していますので、速くなって嬉しいです。
早急なご連絡本当に有難うございました。

[hatena19]

EXCELのバージョンはなんでしょうか。
スピルに対応しているバージョンなら、FILTER関数を使うと早くなるかもしれません。

[vann_2921]

シート内の再計算が遅いのであればマクロの最初に自動計算をオフにして終わりに再計算をするともっと速くなると思います。少なくとも貼り付け秒単位かかるのは考えにくいです。