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

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

hirocom777.hatenadiary.org

前回はシート間のコピーについて、取り組みました。問題はAI（ChatGPT）に作ってもらったのですが、なかなか面白かったです。

そして今回は続きです。AIは他にも問題を考えてくれていたんです。

範囲を指定したコピー_2

それでは今回のお題です。前回の取り組みでAIの出力する日本語が微妙だったので、少し修正を掛けました。

Sheet1のA1~C10の範囲に入力されたデータを、Sheet2のE2-G11の範囲に出力してください。
A1~C10の範囲外の値はコピー対象範囲となりません。

前回のお題ではSheet1のA1~C10の値を、Sheet2のA1~C10に貼り付けていました。今回はコピー先の場所がずれているんですね。以下のコードを書いてみました。

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

    If rng Is Nothing Then Exit Sub  

    Sheets("Sheet2").Range("E2:G11").Value = Me.Range("A1:C10").Value 
End Sub

今回は前回と違ってコピー先のアドレスが異なります。ですので、Intersectで取得した範囲のアドレスをそのまま使用できません。よって、範囲を丸ごと代入しています。取得した範囲のアドレスをそのまま使用するには、RangeオブジェクトのOffsetプロパティを使用しましょう。列方向に4、行方向に1ずれているので

    Sheets("Sheet2").Range(rng.Offset(1, 4).Address).Value = rng.Value

とすればよいですね。

範囲を指定したコピー_3

次のお題です。

Sheet1のA1~C10の範囲に入力されたデータを、Sheet2のA1~A10にコピーしてください。
データは重複データを削除した、ユニークなものにしてください。

今度はユニークなデータをコピーするという条件が付きます。AIも色々考えますね。こんな感じのコードでどうでしょうか。

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

  '指定されている範囲のみ処理
  If Not rng Is Nothing Then
    Dim rng2 As Range
    '変更範囲のすべてのセルをチェックする
    For Each rng2 In rng

    　'重複している値は無効とする
      If rng2.Value <> "" Then
        If 1 < WorksheetFunction.CountIf(Me.Range("A1:A10"), rng2.Value) Then
          Application.EnableEvents = False
          rng2.Value = ""
          Application.EnableEvents = True
        End If
      End If

    Next

    '値をコピーする
    Me.Range("A1:A10").Copy Sheets("Sheet2").Range("A1")
  End If
End Sub

このコードをざっくり解説すると、

Sheet1に入力された場合、範囲がA1~C10の時に処理を実行する
入力された範囲のセルを1つずつチェックしていき、重複している値は消去する
処理が完了したらSheet2のA1~C10にコピーする

といった感じでしょうか。データの重複チェックにはExcelのCountIf関数を使用しました。このコードではShiit1入力時に重複を駆除しました。でも、Sheet1はそのままでSheet2の状態を見て重複していないデータのみコピーする、といった処理でもよさそうです（日本語の解釈がどちらにもとれる）。この場合のコードは以下になります。

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

  '指定されている範囲のみ処理
  If Not rng Is Nothing Then
    Dim rng2 As Range
    '変更範囲のすべてのセルをチェックする
    For Each rng2 In rng

      '重複していない値のみコピーする
      If rng2.Value <> "" Then
        If WorksheetFunction.CountIf(Sheets("Sheet2").Range("A1:A10"), rng2.Value) = 0 Then
          Sheets("Sheet2").Range(rng2.Address).Value = rng2.Value
        End If
      End If

    Next
  
  End If
End Sub

コチラの方がシンプルですね。

ここまでの感想

ここまでやってきての感想なのですが、なかなかおもしろいですね。問題が進んでいくごとに少しずつ課題を追加していって、シンプルなものから徐々に複雑なものへとステップアップしていっています。最初の課題の内容も、続く課題に活用できて学習にもってこいです。日本語が微妙なところがありますが、癖を理解して上手く使っていけばいいのではないのでしょうか。