チェックボックスで選んだ写真、文字を抽出し、別シートへ転記するマクロ

Question

【作りたいマクロ】
原本というシートにある台帳の中から、チェックボックスにチェックがはいっている項目(写真と文章)を抽出し、別シートに転記し、各自台帳内容をカスタマイズができるようにするマクロ。

VBA作成初心者のものです。業務上必要となり調べながら、あるシートを作成しているのですが行き詰ってしまい大変混乱しております。よろしければ、ご教授いただければ幸いです。

現在、写真とその写真の内容を記載した枠が右側に並ぶ台帳を作成し、その各項の右枠横にチェックボックスをおき、チェックボックスにチェックが入った項のみ(下画像だと（B4:AK24)の範囲が1セット)、「シート作成」というボタンを押すと、別シート（「選択」というシート名）に抽出され、転記されるマクロを作成しようとしています。

以下の内容で、チェックボックスにチェックが入った範囲のみ、順に枠と文章などはコピー＆ペーストされていったのですが、写真のみコピーされずに困っています。

Sub 別シートに転記()

Dim cb As CheckBox
Dim St1 As Worksheet
Dim St2 As Worksheet
Dim i As Long
Dim j As Long
Dim k As Long

    Set St1 = Sheets("原本")
    Set St2 = Sheets("選択")
    i = 2
    j = 4
    k = 24

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

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

         'チェックボックスがオンの範囲の台帳を、別シートへコピー＆ペースト
            Range(Cells(j, 2), Cells(k, 37)).Copy
            St2.Select
            St2.Range(Cells(i, 2), Cells(i, 37)).PasteSpecial xlPasteAll
            St1.Select
            
            i = i + 21

        End If

        j = j + 21
        k = k + 21
    Next cb

End Sub

（↑上記のコードで実行したときの選択シート状態です）

ちなみに、更に調べていく中で写真はShapeで構文を書かないといけないと知りまして、枠や文字とは別々にループさせればよいか？と考え、構文を増やしてみましたがエラーが出てしまい、どうしたものかと行き詰まっている状態です（最終エラーは、”Nextに対するForがありません”でした）。

Sub 別シートに転記()

Dim cb As CheckBox
Dim St1 As Worksheet
Dim St2 As Worksheet
Dim shps As Shapes
Dim shp As Shape
Dim area As Range
Dim i As Long
Dim j As Long
Dim k As Long

    Set St1 = Sheets("原本")
    Set St2 = Sheets("選択")
    Set shps = ThisWorkbook.Worksheets("原本").Shapes
    i = 2
    j = 4
    k = 24

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

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

         'チェックボックスがオンの範囲の台帳を、別シートへコピー＆ペースト
            Range(Cells(j, 2), Cells(k, 37)).Copy
            St2.Select
            St2.Range(Cells(i, 2), Cells(i, 37)).PasteSpecial xlPasteAll
            St1.Select
            
            For Each shp In shps
                If shp.Type = msoPicture Then
                Set area _
                 = Intersect(Range(shp.TopLeftCell, _
                   shp.BottomRightCell), _
                    Worksheets("原本").Cells(j, 2))
                   
            If Not (area Is Nothing) Then
               shp.Copy
                    
            St2.Select
            St2.Cells(i, 2).Select
            ActiveSheet.Paste
            St1.Select
            
            i = i + 21

        End If

        j = j + 21
        k = k + 21
    Next cb

End Sub

大変わからりずらい説明文、構文でお恥ずかしいですが、何かしらの方法や、そもそもここが間違っているなどお教え頂ければ幸いです。よろしくお願いいたします。

Answer 1

コピーの部分を以下のようにしたら写真も一緒に貼り付けされませんか？

 'チェックボックスがオンの範囲の台帳を、別シートへコピー＆ペースト
 St1.Range(St1.Cells(j, 2), St1.Cells(k, 37)).Copy St2.Range(St2.Cells(i, 2), St2.Cells(i, 37))

Comments

[kaede0822]

早速、提示してくださったコードを使用して、写真、文章全て、希望通りに別シートへ転記することが出来ました！大変助かりました。ありがとうございました！