Excel チェックボックスにチェックが付いた複数のセルを別のシートにコピー・貼り付けするマクロを教

Excel チェックボックスにチェックが付いた複数のセルを別のシートにコピー・貼り付けするマクロを教えて下さい。

●マクロにしたい作業
シート1に
A1から下に職員名(150名)が記載されており、C1から下に職員名の数だけチェックボックスがあります。

シート1のチェックボックスにチェックが入っている行の職員名をコピーし、シート2のA1から下に貼り付けたいと思っています。

シート1の職員名が入力されているセルはハイパーリンクで同じブック内のシート(例: セルの職員名が"田中"であれば、同じ名前のシート名"田中")に飛ぶようになっており、その仕様もシート2に引き継ぎたいです。

よろしくお願い致します。

No.1 ベストアンサー 回答者： neKo_deux 回答日時： 2020/08/28 14:40

チェックボックスは何種類かありますが、どの種類？あるいはどういう手順で作成したもの？

下記のフォームコントロールで作成したチェックボックスで、

Be COOL Users - チェックボックスの作り方
https://www.becoolusers.com/excel/checkbox.html

チェックボックスの内容がD1から下にTRUE/FALSEで表示されているなら、
E1:=IF($D1, $A1, "")
以下コピペ。
ってしといて、E列をコピー、値を貼り付けとか。

コピー、貼り付けするのを絶対座標でマクロ記録してれば、繰り返し実行できるハズ。


> ハイパーリンクで同じブック内のシート(～)に飛ぶようになっており、

名前とシート名が一致してるなら、HYPERLINK関数で実装できるハズ。

よねさんのWordとExcelの小部屋 - HYPERLINK関数の使い方:Excel関数
http://www.eurus.dti.ne.jp/~yoneyama/Excel/kansu …

この回答へのお礼

こんにちは。
回答ありがとうございます。フォームコントロールでチェックボックスを作成しています。分かりづらい説明ですみません。
チェックボックスの内容がD1から下にTRUE/FALSEで表示されていないため、そこから躓いていました。１つ１つセルのリンクを設定していたのですが、同様の作業が必要なブックが多数あり途方に暮れています。

一括でチェックボックスの内容がD1から下にTRUE/FALSEで表示する方法がありますでしょうか？？

お礼日時：2020/08/28 16:25

No.2 回答者： Qchan1962 回答日時： 2020/08/28 16:04

こんにちは、

＞Excel チェックボックスにチェックが付いた複数のセルを別のシートにコピー・貼り付けするマクロ

チェックボックスにチェックを付けた時に実行するのは、問題が生じるのでしょうか？
チェックを付けた時であれば、チェックボックスが起点になるので比較的容易ですが、、纏めて行う場合
少々判り難くなります。

不明な点などもありますが、補足をいただいても今日は応じられそうにないので、、実行サンプルを下記に記載します。
チェックボックスは、フォームコントロールで、ペースト先C列に作成されるチェックボックスは貼り付け時に削除します。
ご質問のシート1、シート2がシート名です。

Sub sample()
　　'フォームコントロール
　　Dim Lc As Long
　　Dim celLeft As Long, celTop As Long
　　Dim celRight As Long, celBottom As Long
　　Dim Rng As Range
　　Dim objCB As Object, DelCB As Object

　　With Sheets("シート1")
　　　　For Each Rng In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
　　　　　　Lc = .Cells(Rng.Row, .Columns.Count).End(xlToLeft).Column
　　　　　　With Rng.Offset(, 2)
　　　　　　　　celTop = .Top
　　　　　　　　celLeft = .Left
　　　　　　　　celBottom = .Top + .Height
　　　　　　　　celRight = .Left + .Width
　　　　　　End With
　　　　　　For Each objCB In .CheckBoxes
　　　　　　　　If celTop <= objCB.Top And celLeft <= objCB.Left And _
　　　　　　　　　　　　celBottom >= objCB.Top + objCB.Height And celRight >= objCB.Left + objCB.Width Then
　　　　　　　　　　If objCB.Value = xlOn Then
　　　　　　　　　　　　'メイン処理
　　　　　　　　　　　　With Sheets("シート2")
　　　　　　　　　　　　　　Rng.Resize(, Lc).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　　　　　　　　　　　For Each DelCB In .CheckBoxes
　　　　　　　　　　　　　　　　If Not Intersect(DelCB.TopLeftCell, .Cells(Rows.Count, 1).End(xlUp).Offset(, 2)) _
　　　　　　　　　　　　　　　　　　　　Is Nothing Then DelCB.Delete: Exit For
　　　　　　　　　　　　　　Next
　　　　　　　　　　　　End With
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
End Sub

この回答へのお礼

不明な点が多くすみませんでした。
教えて頂いたコードを参考にさせて頂きます。

お礼日時：2020/08/28 16:54