シート間のコピー（VBA研究会議事録_08）

VBA研究会で論じられた内容を記録する議事録の8本目（2023/03/11開催分）です。前回の議事録はコチラになります。

hirocom777.hatenadiary.org

前回はフォルダー作成の問題に取り組みました。フォルダーを大量に作成する作業はを自動化できます。

順調に続いているVBA研究会なのですが、毎回障害になっているのが問題の作成です。面白くてちょうどいい頃合いの問題を作るのって難しいんですよ。そこで、今話題になっているAI（ChatGPT）に問題を作ってもらうことにしました。

早速取り組んでみましょう。

シート間のコピー

最初の問題がこちらです。

Worksheet_Changeイベントを使用して、Sheet1に入力されたデータをSheet2に自動的にコピーするマクロを作成してください。

折角なのでWorksheet_Changeイベントの使い方もおさらいしましょう。Worksheet_Changeイベントを使うと対象シートのセルの値が変更されたときに、VBAの処理を実行できます。Worksheet_Changeイベントを使うには、対象のシートモジュール内に以下のコードを書きます。

Private Sub Worksheet_Change(ByVal Target As Range)
’ここにVBAの処理を書く
End Sub

該当シートのセルの値が変わるたびに、このプロシージャが呼び出されます。引数「Target」には、変更が発生したRangeオブジェクトが渡されます。処理内容は、以下の様に書けばいいでしょう。

Private Sub Worksheet_Change(ByVal Target As Range)
  Sheets("Sheet2").Range(Target.Address).Value = Target.Value
End Sub

Targetの値をSheet2のTarget.Addressで指定した所に代入（コピー）します。

範囲を指定したコピー

お次はコチラ。

以下の条件を満たすマクロを作成してください。シート名が"Sheet1"のセルA1からA10までに値が入力された場合、それらの値をシート名"Sheet2"にコピーします。コピーされるセルは、"Sheet2"のセルA1からA10まででなければなりません。データが更新された場合は、"Sheet2"の既存のデータを更新する必要があります。

今度は範囲の指定が追加されています。コチラはChatGPTに回答も作ってもらいました。（1問目の回答とのことでしたが、多分内容的にこの問題の回答だと思います）

'GPTのコード
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
        Sheets("Sheet2").Range(Target.Address).Value = Target.Value
    End If
End Sub

なるほど。Target.Cells.CountLargeで変更になったセルの個数を確認しているんですね。CountLargeプロパティはCountプロパティの上位版。シート内のセル数がLong値で表せる範囲を越えてしまうのでコチラが用意されたと言う訳です。

続いて、Intersectメソッドを使って変更内容が範囲内かどうかを確認しています。Intersectメソッドは複数のRangeオブジェクトから、重なった部分をRangeオブジェクトで返します。重なっている部分がない場合はNothingを返します。重なっている部分がある場合には値をコピーします。この部分は1問目の回答と同じですね。

動かしてみると、正常に動いているように見えます。

でも、ちょっと惜しい！！

これだと貼り付け等で複数のセルに入力したときに、値が反映されません。セルの個数を1つに制限しているからです。そこで我々が考えたコードが以下になります。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Set rng = Intersect(Target, Me.Range("A1:A10"))

    If rng Is Nothing Then 
        Exit Sub
    Else
        Sheets("Sheet2").Range(rng.Address).Value = rng.Value 
    End If
End Sub

IntersectメソッドでセルA1からA10と重なっているRangeオブジェクトを取得。重なっている部分がある場合にはコピーを実行します。これでバッチリですね！！