【VBA】Excelで、ひとつ上の可視セルの値を取得して貼り付けする

Excelでフィルタの適用状態に関わらず、任意のセルの（見た目上の）ひとつ上のセルの値を取得しようというもの。

元ネタはこちら
koroko.hatenablog.com
別の方法で、こちらでも。
infoment.hatenablog.com

両者とは別のアプローチで・・・

目次

抑えておくべき事

Range.Areasオブジェクト

MSのサイトより抜粋。

選択範囲内にある領域 (隣接しているセルのブロック) のコレクションです。

Areasコレクションの各メンバーは、 Range オブジェクトです。 Areasコレクションには、選択範囲内の各セルの不連続な連続した範囲のrangeオブジェクトが1つ含まれています。 選択範囲に領域が1つしか含まれていない場合、 Areasコレクションには、その選択範囲に対応するRangeオブジェクトが1つだけ含まれます。

https://docs.microsoft.com/ja-jp/office/vba/api/excel.areas

Rangeオブジェクトは、Range("A1:C3") といった指定をした場合のように、単一の矩形領域の場合だけでなく
Rrange("A1:C3,D2:F4")とか、Unionメソッドにより複数の矩形領域を纏めてひとつのRangeオブジェクトとして扱ったりする場合もあります。
それらの１個以上の矩形領域をCollectionとして纏められたものが、Range.Areasオブジェクトです。

Itemプロパティ

Areasオブジェクトに含まれているひとつの要素（Rangeオブジェクト）を返すプロパティです。

構文
Areas.Item(Index)

パラメーター

名前	必須/オプション	データ型	説明
Index	必須	Long	オブジェクトのインデックス番号を指定する。

省略記法
Areas(Index)
という記述でも同様に処理できます。

Countプロパティ

Areasコレクションに含まれるオブジェクトの数を返すプロパティです。
これにより前述のItemプロパティに指定できるインデックスの上限値がわかります。
構文
Areas.Count

実際の例

領域が分かれることで、Areas.Countが増え、それぞれの要素（Rangeオブジェクト）の情報（下の例ではAddress）を取得できています。

フィルターを使用している場合

フィルター適用前の状態が下図の要なデータで見てみる。

C列のデータを選択した状態

B列をDDで抽出した状態

SpecialCells(xlCellTypeVisible)を指定しないと、非表示のセルも含まれてしまう。
SpecialCells(xlCellTypeVisible)を指定することで、可視セルのみを対象としている。
また、非表示セルが間に入ると、Areasオブジェクト内のItemプロパティで取得する領域が別々になっている。

処理

考え方

1. 上記のフィルター適用時の結果から、基準となるセルの上の全てのセルのうち、表示されているセルと、基準のセルをUnionで纏める。
2. 基準となるセルは、Unionで纏めたRangeの一番下なので、Areas.Item(Areas.Count) にある。
3. Areas.Item(Areas.Count).Rows.Count が１ならば、基準セルのひとつ上のセル（見た目ではなく実際の１行上のセル）は非表示なので、Areas.Item(Areas.Count-1) の一番下のセルが求めるセル。
4. Areas.Item(Areas.Count).Rows.Count が２以上なら、基準セルの１行上のセルは表示されているので、基準セルの１行上のセルが求めるセル。

コード

取得データ貼り付け処理

アクティブRangeを指定して、データを取得して貼り付ける処理

Public Sub pasetFromAboveCellsValue()

    Dim vTargetValues() As Variant
    Dim isSuccess       As Boolean
    Dim i               As Long

    'データ取得
    isSuccess = getFromAboveCellsValue(Selection, vTargetValues)

    If Not isSuccess Then
        Call MsgBox("失敗したよ。", vbOKOnly + vbCritical, "ひとつ上の可視セルコピー")

        Exit Sub
    End If

    '取得したデータ貼り付け
    For i = 0 To UBound(vTargetValues)
        Selection.Item(i + 1).Value = vTargetValues(i)
    Next i

End Sub

データ取得処理

指定したRangeのひとつ上の可視セルの値を取得する処理

パラメータ	IN/OUT	説明	備考
rBaseRange	IN	基準となるRange	同一行の連続したセルを指定可
vTargetValues	OUT	指定されたRangeのひとつ上の可視セルの値が格納された配列

復帰値

True	正常取得
False	エラー

Private Function getFromAboveCellsValue(ByRef rBaseRange As Range, ByRef vTargetValues() As Variant) As Boolean

    Dim rTargetAreas    As Range
    Dim rTargetArea     As Range
    Dim lTargetRow      As Long
    Dim i               As Long

    If rBaseRange.Row = 1 Then
        '先頭行なら処理しない
        Exit Function
    ElseIf rBaseRange.Rows.Count > 1 Then
        '複数行選択されていたら処理しない
        Exit Function
    ElseIf rBaseRange.Areas.Count > 1 Then
        '連続していな領域なら処理しない
        Exit Function
    End If

    'コピー元となるRange選択
    Set rTargetAreas = rBaseRange.Resize(rBaseRange.Row - 1, rBaseRange.Columns.Count).Offset(-rBaseRange.Row + 1)

    '非表示セルを除外
    Set rTargetAreas = rTargetAreas.SpecialCells(xlCellTypeVisible)

    'コピー先Rangeを含める
    Set rTargetAreas = Union(rTargetAreas, rBaseRange)

    With rTargetAreas
        If .Areas.Item(.Areas.Count).Rows.Count = 1 Then
            'コピー先の１行上が非表示なら、最終Areaのひとつ前のAreaがコピー元になる
            Set rTargetArea = .Areas.Item(.Areas.Count - 1)

            '対象Areaの最終行がコピー元
            lTargetRow = rTargetArea.Rows.Count
        Else
            'コピー先の１行上が表示なら、最終Areaがコピー元になる
            Set rTargetArea = .Areas.Item(.Areas.Count)

            '対象Areaの最終行のひとつ上がコピー元
            lTargetRow = rTargetArea.Rows.Count - 1
        End If
    End With

    ReDim vTargetValues(rBaseRange.Columns.Count - 1)

    For i = 1 To rBaseRange.Columns.Count
        vTargetValues(i - 1) = rTargetArea.Item(lTargetRow, i).Value
    Next i

    getFromAboveCellsValue = True

End Function

コードをコピーしたい方へ

いつもの通り、コードはダブルクリックすれば選択できますので・・・

使い方

pasetFromAboveCellsValueをイミディエイトウィンドウから呼ぶなり、
適当なボタンに登録するなり、使いやすいようにして下さい。

実行サンプル

最後に

今回は、前回のやつがあったから気がつけた。
ちょっと満足。

z1000s.hatenablog.com

貼り付けだけが目的であれば、プロシージャを分けずに１つにした方が
無駄なコピーが無くせるので、スッキリするかも。

単一のセルだけでなく、複数のセルに対応したのと
データの途中の行でも実行可能なので、少しは使えるか？