すぐに役立つエクセルVBAマクロ集 FAQ 等間隔に抽出して一覧を作成

　すぐマク　YNxv9868

等間隔に存在するデータを抽出して別の列に一覧を作成するには？

Ｑuestion 72.5　値の操作

マクロでやりたい操作があり "Excel VBAマクロ組み方講座"を購入したのですが、本書の中に該当項目が見当たらず困っています。
実際にやりたい操作は "等間隔に存在するデータの抽出" です。以下に例を記述しますので、ご回答いただけると幸甚です。
やりたい操作
1. ワークシート上の任意のセルをスタート位置として(例えばA1)から、下に19番目(例えばA20)の
　セルのデータをコピーし、それを開始した任意のセルの右3つ目のセル(例えばD1)に数値のみ
　貼り付ける。
2. 次の動作はスタート位置からA20から下に19番目(例えばA39)のデータをコピーし、セルD2に
　数値のみ貼り付ける。
3. 対象列にデータがなくなるまで繰り返し、A列の必要データのみを抽出した一覧をD列に作る。
以上です。
このような、非常に単純なカーソル制御とデータピックアップの操作ですが、どうも見当たりませんでした。
パソコン環境は Excel 2002 & Windows 2000 です。

Answer　　

拙著をご購入いただき、ありがとうございます。お知りになりたいことが掲載されていなくてということですが、今後、別件の開発などに役立てていただければ幸いです。

あなたがなさりたいことは、左図のとおりでしょうか。
やりたい操作の 1. と 2. はマクロの自動記録で出来ますから、すでに、おやりになって、下記のようなマクロが出来ているかと思います。

Sub Macro1()
    Range("A20").Select
    Selection.Copy
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A39").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

このマクロが原型ですから、これを繰り返し処理で行えるよう、下記のように改造します。

Sub Macro12()
    貼付行 = 0
    For コピー行 = 20 To 39 Step 19
        貼付行 = 貼付行 + 1
        Range("A" & コピー行).Select
            Selection.Copy
        Range("D" & 貼付行).Select
            Selection.PasteSpecial Paste:=xlPasteFormulas
    Next
End Sub

次の改造は、やりたいこと 3. の「対象列にデータがなくなるまで繰り返し」できるようにする機能を追加します。
ついでに、自動記録されたコピー貼り付け関係のコードを整理しておくと、見やすくなります。

Sub Macro13()
    下端行 = Range("A65536").End(xlUp).Row
    貼付行 = 0
    For コピー行 = 20 To 下端行 Step 19
        貼付行 = 貼付行 + 1
        Range("A" & コピー行).Copy
        Range("D" & 貼付行).PasteSpecial Paste:=xlPasteFormulas
    Next
End Sub

以上が回答になりますが、拙著 290～292ページに「データ件数取得と繰り返し処理と・・」と題する解説がありますから参考にして、改造した各コードの意味をご理解ください。

http://www.happy500z.com/