【Excel VBA】上のセルの文字を下までコピーする

このページで書くこと

以下のような虫食い状態の表があったとします。

りんごA	美味しい
	普通
	まずい
りんごB	美味しい
	...

それを、このようにすべてのセルに適切な文字が入っている状態にします。

りんごA	美味しい
りんごA	普通
りんごA	まずい
りんごB	美味しい
りんごB	...

経緯

上記のような表はなかなかないかもしれませんが、私が働いている会社だと組織図がこの書き方なんですよね。
見やすさを重視した結果なので仕方ないとは思いますが、フィルタリングするときや（「りんごA：美味しい」のように）関数で繋げたいときは面倒です。

作成したもの

以下のように空欄がある組織図を、上のセルの文字で埋めます。

f:id:arekoretips:20220417000934p:image:w400 — 空欄を埋める

使用する前の用意（要確認）

上記の画像を見ていただくとわかるように、表の一番下（A20セル）に「ここまで」と入れてあります。
理由は後述しますが、これを入れておかないと1,048,576行目まで入力されてしまうので入力必須です。
特に、コードをコピーして使用される方はご注意ください。

使用するコード

以下のコードで動いています。

Sub ORG()
'
    Dim OrgSheet As Worksheet
    Dim trgVal As String '対象列
    Dim cellVal As String 'セルの文字列
    Dim rowNum As Long 'セルの行数
    '
    Set OrgSheet = ThisWorkbook.Worksheets("組織図")
    trgVal = "A"
    cellVal = ""
    '
    OrgSheet.Activate
    '
    '1行目から1,048,576行目まで繰り返し
    For rowNum = 1 To 1048576
    '
        '[Ctrl]+[↓]
        OrgSheet.Range(trgVal & rowNum).End(xlDown).Select
        rowNum = ActiveCell.Row
        cellVal = ActiveCell.Value
        '「ここまで」と書いてあったら処理を停止
        If cellVal = "ここまで" Then Exit For
        '次に文字が入っているセルまでにcellValの値を挿入
        Range(trgVal & rowNum, Range(trgVal & rowNum).End(xlDown).Offset(-1)).FillDown
    '
    Next rowNum
'
End Sub

使用上の注意（要確認）

1行目は必ず見出しにしてください。
1列ずつ動作させてください（A列とB列を同時に……ということはできません）。
空欄埋めをする列の最終行の後ろに「ここまで」と入力してください。
上記コードの8行目（Set OrgSheet = ThisWorkbook.Worksheets("組織図")）の「組織図」を空欄埋めをするシート名に変更してください。
上記コードの9行目（trgVal = "A"）の「A」を、空欄埋めをする列番号に変更してください。

これで準備OKです。コードを実行してください。

後述しますが、対象のシート名や対象の列はコードに直接書くのではなく、別シートに書いておき、それを参照する方法もあります。

解説

ざっくり

行っている処理についてざっくり言うと、対象列の1行目から[Ctrl]+[↓]キーを押して、次に入力されているセルがどこかを調べ、その間を埋めています。
[Ctrl]+[↓]キーを押しているので、最終行の後ろに「ここまで」と書かないと1,048,576行目まで入力してしまうのです（汗）

詳細

今回の処理にあたってほしいデータは
・対象の列
・コピーする値の文字
・何行目まで処理したか
の3つです（各変数）。

まず、対象列の1行目を選択した状態で[Ctrl]+[↓]キーを押す処理をしています。選択セルは2行目に移ります（OrgSheet.Range(trgVal & rowNum).End(xlDown).Select）。
＊Range.End(xlDown)で[Ctrl]+[↓]

次に、移動した先のセルの値と行番号を控えておきます（rowNum = ActiveCell.Row、cellVal = ActiveCell.Value）。

最後に、現在選択しているセルを基準に、[Ctrl]+[↓]キーを押す処理で次に値が入っているセルを確認し、その上のセルまで一気に埋めます（Range(trgVal & rowNum, Range(trgVal & rowNum).End(xlDown).Offset(-1)).FillDown）。
ここは複雑な書き方をしていますが、

（内側の）Range.End(xlDown)で[Ctrl]+[↓]
Offset(-1)で1つ上の行に移動（Offset(1)で1つ下、Offset(-1)で1つ上の行に移動する）
（外側の）Range.FillDownで範囲内の全セルに挿入

という流れです。

もし、そのときに選択しているセルが「ここまで」のセルだった場合は処理を終了します（If cellVal = "ここまで" Then Exit For）。

上記の処理を1行目から1,048,576行目まで（正しい使い方をすれば「ここまで」のセルまで）繰り返しています（For rowNum = 1 To 1048576）。

もう少し便利にする

今回はコードを直接編集し、対象列や対象のシートを変更しましたが、個人的には操作のためにコードを編集するのは危険だと思います。
そこで、以下のような「設定」というシートを作成し、そこに対象列と対象のシート名を入力するようにしました。

f:id:arekoretips:20220417012048p:image:w400 — 「設定」シート

「設定」シートのB1、B2セルに必要な情報を入力した後、以下のコードを実行することで上記のコードと同様の処理を行います（「設定」シートの情報を反映する処理のみ追加しています）。
＊「ここまで」は入力してください。

Sub ORG()
'
    Dim SetSheet As Worksheet
    Dim orgS As String
    Dim OrgSheet As Worksheet
    Dim trgVal As String '対象列
    Dim cellVal As String 'セルの文字列
    Dim rowNum As Long 'セルの行数
    '
    Set SetSheet = ThisWorkbook.Worksheets("設定")
    orgS = SetSheet.Range("B1").Value
    Set OrgSheet = ThisWorkbook.Worksheets(orgS)
    trgVal = SetSheet.Range("B2").Value
    cellVal = ""
    '
    OrgSheet.Activate
    '
    '1行目から1,048,576行目まで繰り返し
    For rowNum = 1 To 1048576
    '
        '[Ctrl]+[↓]
        OrgSheet.Range(trgVal & rowNum).End(xlDown).Select
        rowNum = ActiveCell.Row
        cellVal = ActiveCell.Value
        '「ここまで」と書いてあったら処理を停止
        If cellVal = "ここまで" Then Exit For
        '次に文字が入っているセルまでにcellValの値を挿入
        Range(trgVal & rowNum, Range(trgVal & rowNum).End(xlDown).Offset(-1)).FillDown
    '
    Next rowNum
'
End Sub

このように設定用のシートを作成しておけば、たとえば複数の列・複数のシートで処理を行いたい場合、編集が楽になります。
誤って必要なコードを消してしまい動作しなくなることもありませんのでオススメです。

以上です。

技術tips保管庫

Excel VBAを中心に、仕事で役立つあれこれを記録