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

Question 72.5   Previous Next
マクロでやりたい操作があり " Excel VBAマクロ組み方講座 "を購入したのですが、本書の中に該当項目が見当たらず困っています。
実際にやりたい操作は "等間隔に存在するデータの抽出" です。 以下に例を記述しますので、ご回答いただけると幸甚です。
やりたい操作
1. ワークシート上の任意のセルをスタート位置として(例えばA1)から、下に19番目(例えばA20)の
  セルのデータをコピーし、それを開始した任意のセルの右3つ目のセル(例えばD1)に数値のみ
  貼り付ける。
2. 次の動作はスタート位置からA20から下に19番目(例えばA39)のデータをコピーし、セルD2に
  数値のみ貼り付ける。
3. 対象列にデータがなくなるまで繰り返し、A列の必要データのみを抽出した一覧をD列に作る。
以上です。
このような、非常に単純なカーソル制御とデータピックアップの操作ですが、どうも見当たりませんでした。パソコン環境は Excel 2002 & Windows 2000 です。
Answer   Copyright (C) 2005.3.28 永井善王
拙著をご購入いただき、ありがとうございます。 お知りになりたいことが掲載されていなくてということですが、その本は今後、別件の開発などに役立てていただければ幸いです。
あなたがなさりたいことは、左図のとおりでしょうか。
やりたい操作の 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ページに「データ件数取得と繰り返し処理と・・」と題する解説がありますから参考にして、改造した各コードの意味をご理解ください。

 

Excel VBA Macro