【VBA】指定の項目だけをコピーする

マスタから決まった項目だけコピーしたいことってありますよね。
そんな時使えます。

実際に書いてみた

Option Explicit

Sub test()

Dim 項目
Dim Rng As Range
Dim n As Long
Dim Maxrow As Long

'抽出したい項目を配列に入れる
項目 = Range("A1:E1")

'2番目の次元の添え字の最大値で回す
For n = 1 To UBound(項目, 2)
    
    'findで位置を確認
    Set Rng = Sheets("データ").Range("1:1").Find(What:=項目(1, n))
    If Rng Is Nothing Then
        MsgBox "項目が見つかりません"
        Exit Sub
    End If
    
    '最終行を取得
    Maxrow = Sheets("データ").Cells(Rows.Count, Rng.Column).End(xlUp).Row
    
    'コピペする
    Sheets("データ").Cells(Rng.Row, Rng.Column).Resize(Maxrow).Copy Destination:=Sheets("貼り付け先").Cells(1, n)

Next n

End Sub

解説的なもの

めちゃくちゃシンプルなコードです。

項目 = Range(“A1:E1”)

項目という配列に欲しいデータの項目名いれます。

別にRange(“A1:A10”)とかでもいいですし、レンジのなかは何でもいいです。

For n = 1 To UBound(項目, 2)

Uboundは次元の添え字の最大値を返します。

今回は項目という配列の最大値を出すのですが、となりに２とありますよね。
これは次元の番号です。

２なので２次元です。
横に見てくってことですね。
縦に見たい時は１か、なんにもなしでOKです。

findはそのまんま

findでほしい項目の位置を割り出しています。
setを忘れがちです。

コピーする

Sheets(“データ”).Cells(Rng.Row, Rng.Column).Resize(Maxrow).Copy Destination:=Sheets(“貼り付け先”).Cells(1, n)

.Cells(Rng.Row, Rng.Column)これはRngと全く同じものです。
RngがA１ならこの項目もＡ１です。

コピーを使うのに、変数だとエラーが出るのでこういうまどろっこしい書き方にしました。