選択範囲の指定列だけを抜き出して、別の個所に貼り付ける

「選択範囲の指定列から値だけを抜き出して、別の個所に貼り付ける」というニーズがあったので作ってみました。備忘録として、ここに残しておきます。

まず、クラスモジュールを一つ準備します。名前は「SequenceClass」としますが、お好みで命名していただいて構いません。

[クラスモジュール]
※今回作成したのは、最後の「ExtractArray」だけです。それ以外は、今までにも当ブログで紹介済みです。

'[用 途]
'   配列の指定インデックスの数を取得
Private Property Get SeqRowsAndColumnsCount(target_array As Variant, rc_index As Long) As Long
    SeqRowsAndColumnsCount = UBound(target_array, rc_index) - LBound(target_array, rc_index) + 1
End Property
'[用 途]
'   配列の次元数取得
'[引 数]
'   seq As Variant  配列
'[戻り値]
'   正常終了    配列の次元数
'   -1の場合    異常終了 ※つまり、seqは配列ではない
Private Function GetArrayDimension(seq As Variant) As Long
    If IsArray(seq) = False Then
        GetArrayDimension = -1
        Exit Function
    End If
    ' 配列の次元数を取得。
    Dim i As Long
    Dim TempNumber As Long
        On Error Resume Next
        Do While Err.Number = 0
            i = i + 1
            TempNumber = UBound(seq, i)
        Loop
        GetArrayDimension = i - 1
End Function
'[用 途]
'   指定セルに配列を貼り付ける。
'[引 数]
'   target_range As Range     配列を貼り付けるセル
'   target_array As Variant   貼り付けられる配列
'[戻り値]
'    0の場合    正常終了
'   -1の場合    異常終了 ※target_arrayは配列ではない。
'   -2の場合    異常終了 ※配列の次元数が3以上。
Function PasteArray(target_range As Range, target_array As Variant) As Long
    ' 配列の次元数取得
        PasteArray = GetArrayDimension(target_array)
        If PasteArray = -1 Then
            Exit Function
        Else
            Dim DimensionNumber As Long
                DimensionNumber = PasteArray
        End If
    ' 貼り付け行数の取得。
    Dim rMax As Long
        rMax = SeqRowsAndColumnsCount(target_array, 1)
        Select Case DimensionNumber
        ' 一次配列の場合。
            Case 1
                target_range.Resize(rMax) = WorksheetFunction.Transpose(target_array)
        ' 二次配列の場合。
            Case 2
                Dim cMax As Long
                    cMax = SeqRowsAndColumnsCount(target_array, 2)
                    target_range.Resize(rMax, cMax) = target_array
        ' 三次以上の場合。 ※未対応。
            Case Else
                PasteArray = -2
        End Select
End Function

↓ が、今回作成した箇所です。指定列のデータで配列を再編成しています。

'[用 途]
'   指定範囲から、指定列番号のみ抽出した配列を作成
'   ※指定範囲は、配列を指定可能
'[引 数]
'   target_data          As Variant 抽出対象となる範囲
'   extract_column_array As Variant  抽出される列情報(配列)
'   例)1,3,5行目を抜き出す ⇒ extract_column_array = Array(1,3,5)
'[戻り値]
'   配列の場合  正常終了
'   -1の場合    異常終了 extract_column_arrayの指定が不適切
'   -2の場合    異常終了 target_dataが範囲または配列以外
'   -3の場合    異常終了  抽出指定が元データの範囲を超えている
Public Function ExtractArray(target_data As Variant, extract_column_array As Variant) As Variant

    ' 抽出列の指定方法確認。
        If GetArrayDimension(extract_column_array) <> 1 Then
            ExtractArray = -1: Exit Function
        End If

    ' 抽出対象が範囲または配列以外の場合は処理中断。
        If TypeName(target_data) = "Range" Then
            If target_data.Rows.Count = 1 Or target_data.Columns.Count = 1 Then
                ExtractArray = target_data
                Exit Function
            End If
        ElseIf IsArray(target_data) = False Then
            ExtractArray = -2: Exit Function
        End If
    Dim DataSeq As Variant
        DataSeq = target_data

    ' 抽出列が抽出対象の範囲を超えている場合、処理を中断。
        If UBound(DataSeq, 2) < extract_column_array(UBound(extract_column_array)) Then
            ExtractArray = -3: Exit Function
        End If

    ' 抽出後の配列定義。
    Dim rMax As Long
        rMax = SeqRowsAndColumnsCount(DataSeq, 1)
    Dim cMax As Long
        cMax = SeqRowsAndColumnsCount(extract_column_array, 1)

    Dim TempSeq As Variant
    ReDim TempSeq(1 To rMax, 1 To cMax)

    ' 抽出後の配列作成。
    Dim r As Long
    Dim c As Long
    Dim i As Long
        i = 0
        For c = 1 To cMax
            For r = 1 To rMax
                TempSeq(r, c) = DataSeq(r, extract_column_array(i))
            Next
            i = i + 1
        Next

        ExtractArray = TempSeq

End Function

元データである「target_data」が範囲(Range)である場合、一旦配列化してから処理しています。従ってこの部分は、「Selection」のような指定でもOKです。
ただし、「target_data」が三次元以上の配列である場合を想定していませんので、注意が必要です。

さて、前置き部分が長くなってしまいましたが、使用方法です。
例)下表のうち、2,3,5列目だけを抜き出して別の個所に書き出したい。

f:id:Infoment:20180902062205p:plain

[標準モジュール]

Sub Sample()
    Dim SQC As SequenceClass
    Set SQC = New SequenceClass
    Dim seq As Variant
        seq = SQC.ExtractArray(Range("A1:E4"), Array(2, 3, 5))
        SQC.PasteArray Range("A6"), seq
End Sub

まず必要な個所のデータだけを格納した配列「seq」を、今回新作の関数「ExtractArray」で作成します。そして、同クラスモジュール内の「PasteArray」で一気に張り付ける、という手順になっています。
f:id:Infoment:20180902064046p:plain

でも正直なところ、抜き出したデータを用いて更に処理するなら、最近はこちらの方法で行うようにしています。
thom.hateblo.jp


参考まで。