『チェックボックスで選択したセルの転記について』（八家）

こんばんわ

お聞きしたいことがあり投稿しました。

以下のようなシートがあるとします。

_A_________　　　　　B_______　C_______　
 1 チェックボックス?@  ミカン　　　　　　　
 2 チェックボックス?A  モモ
 3 チェックボックス?B  レモン

A列のチェックボックスにチェックを入れると
C列に転送できるマクロを作りたいと考えています。
例えば、
チェックボックス?@と?Bをチェック後、ボタンを押すと、
C列に、・・・

_A_________　　　　　B_______　C_______　　
 1 チェックボックス?@  ミカン　　ミカン　　
 2 チェックボックス?A  モモ　　　レモン
 3 チェックボックス?B  レモン

・・という感じにしたいと考えています。

それが、以下のようなコードです。

==========================================
Sub ボタン6_Click()
    
Dim cb As CheckBox
Dim i As Long
Dim j As Long
Dim Tmp() As Variant

    i = 0
    j = 1

    'チェックボックスをループ
    For Each cb In ActiveSheet.CheckBoxes

        'チェックボックスがオンだったら
        If cb.Value = xlOn Then

            '配列の要素数を指定
            ReDim Preserve Tmp(i)

            '配列にA〜C列の値を格納
            Tmp(i) = Cells(j, 2)
            i = i + 1

        End If

        j = j + 1

    Next cb

    '配列に格納したデータをH列から転記
    For i = 0 To UBound(Tmp)
        Cells(i + 1, 3) = Tmp(i)
      
        
    Next i
       

End Sub






==========================================
ただ、ここで問題点があります。
チェックボックスのチェックを外した場合、うまく消えないのです。

例えば、チェックボックス?@?A?Bにチェックを入れると、

_A_________　　　　　B_______　C_______　
 1 チェックボックス?@  ミカン　　ミカン　　　　　
 2 チェックボックス?A  モモ　　　モモ
 3 チェックボックス?B  レモン　　レモン

・・となりますが、次に、例えば、チェックボックス?Bにチェックを外しても、
変化がないのです。(c列からレモンが消えない)
おそらく、最終セルとして処理すれば消えるのではないかと思っているのですが、
うまくいきません。

以上になります。恐れ入りますがご教授願います。



＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
----
 参考に
 Sub ボタン7_Click()
    Dim cb As CheckBox
    Dim i As Long
    Dim j As Long
    
    'チェックボックスをループ
    For Each cb In ActiveSheet.CheckBoxes
        j = j + 1
        Cells(j, 3).ClearContents
        'チェックボックスがオンだったら
        If cb.Value = xlOn Then
            i = i + 1
            Cells(i, 3).Value = Cells(j, 2).Value
        End If
    Next cb
 End Sub

（ピンク） 2022/06/27(月) 00:40
----
ピンク様
返信が遅くなり申し訳ありません
無事にできました
ありがとうございました。
配列にこだわらなくてもピンク様のコードのほうがシンプルでわかりやすいですね
（八家） 2022/06/27(月) 08:28
----
 >配列にこだわらなくても
 配列にこだわれば

 Sub ボタン8_Click()
    Dim cb As CheckBox
    Dim i As Long
    Dim j As Long
    Dim Tmp()
    For Each cb In ActiveSheet.CheckBoxes
        i = i + 1
        ReDim Preserve Tmp(1 To i)
        If cb.Value = xlOn Then
            j = j + 1
            Tmp(j) = Cells(i, 2).Value
        End If
    Next cb
    Range("C1").Resize(UBound(Tmp)).Value = Application.Transpose(Tmp)
 End Sub

（ピンク） 2022/06/27(月) 12:57
----
ピンク様

配列コードもご紹介いただきありがとうございました！！
勉強させていただきます
（八家） 2022/06/27(月) 13:39