選択範囲の指定列だけを抜き出して、別の個所に貼り付ける
「選択範囲の指定列から値だけを抜き出して、別の個所に貼り付ける」というニーズがあったので作ってみました。備忘録として、ここに残しておきます。
まず、クラスモジュールを一つ準備します。名前は「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列目だけを抜き出して別の個所に書き出したい。
[標準モジュール]
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」で一気に張り付ける、という手順になっています。
でも正直なところ、抜き出したデータを用いて更に処理するなら、最近はこちらの方法で行うようにしています。
thom.hateblo.jp
参考まで。