貼り付け処理について

投稿者 : めしばな     投稿日時 : 2025/06/09(Mon) 19:36:59     OS : 未指定     EXCEL : 未指定

---

伝えづらいので画像を用意しました。
画像A(https://ibb.co/hFYCWgFS)という元の表があります。
左の枠内に右の青いセルを張り付けると、青いセルの下にある赤枠セルを張り付けるvbaをなんとか自力で作成できましたが。
ご質問したいのが、画像B（https://ibb.co/Jj7HtNLJ）のように、枠内に青いセルを適当に貼り付けても、赤枠セルの行数分とかぶらないようにして、次の青いセルの内容（下の赤い行数分）を張り付けるようにしたいのですが、そんなこと可能でしょうか？
可能でしたらvbaコード教えていただきたいです。
わかりにくい説明すいませんが、優しいかたよろしくお願いします。

投稿者 : さんこう     投稿日時 : 2025/06/10(Tue) 08:20:37

---

＞わかりにくい説明

説明を読んでも、画像を見てもさっぱりわかりませんので、画像Bを再現するような感じで作ってみました。
（画像BのB～D、L～Q列がある状態で実行すると、H～J列に書き込む）

参考になれば。

Sub ぜんぜんわからないのでちょうてきとう()
    Range("H2:J50").ClearContents
    
    For c0 = 2 To 4
        r1 = 2
        c1 = c0 + 6
        For r0 = 2 To 18
            If Cells(r0, c0) <> "" Then
                For j = 12 To 17
                    If Cells(2, j) = Cells(r0, c0) Then Exit For
                Next
                If j <= 17 Then
                    Cells(r1, c1) = Cells(r0, c0)
                    r1 = r1 + 1
                    k = 3
                    Do While Cells(k, j) <> ""
                        Cells(r1, c1) = Cells(k, j)
                        r1 = r1 + 1
                        k = k + 1
                    Loop
                    r1 = r1 + 2
                End If
            End If
        Next
    Next
End Sub

投稿者 : てらてら     投稿日時 : 2025/06/10(Tue) 19:38:06

---

こんにちは。
勝手に解釈してみました。

Sub testcode()
    Dim i As Long, j As Long, col As Long
    Dim lastRow As Long, lastRow2 As Long
        
    For j = 2 To 4  'B列～D列
        lastRow = ActiveSheet.Cells(Rows.Count, j).End(xlUp).row
        '最初に間にある空白を削除
        For i = lastRow To 2 Step -1
            If Cells(i, j) = "" Then
                Cells(i, j).Delete Shift:=xlUp
            End If
        Next i
        
        'L列～Q列の値を挿入していく
        lastRow = ActiveSheet.Cells(Rows.Count, j).End(xlUp).row
        For i = lastRow To 2 Step -1
            For col = 12 To 16
                If Cells(1, col) = Cells(i, j) Then
                    lastRow2 = ActiveSheet.Cells(Rows.Count, col).End(xlUp).row
                    Range(Cells(2, col), Cells(lastRow2 + 2, col)).Copy
                    Cells(i + 1, j).Insert Shift:=xlDown
                End If
            Next col
        Next i
    Next j
End Sub

投稿者 : ピロリ     投稿日時 : 2025/06/10(Tue) 23:56:36

---

私は、画像Bの H～J列は 実際は B～D列のこと、画像Bの L～G列は 実際は F～K列のことを言って
いるのかなぁ～と勝手に解釈しました。（何か、画像Bが漫画っぽいので･･･）
①シートは、画像A（B2:D28に入力枠、F～K列に都道府県のメンバー表）のようなフォーマット。
②B2:D28の枠内に都道府県名を入力して、マクロを実行する。
③マクロは、入力した都道府県名へ F～K列のメンバー表（都道府県名とメンバー名）をコピペ。
　但し、メンバー表が被らないようにコピペ。上のメンバー表と下のメンバー表は２行空ける。
だとすれば、下の様な感じでも。　解釈が誤ってたなら、読み捨てて下さい。

Sub Sample()
    Dim Tbl As Range: Set Tbl = Range("B2:D28")     '枠の範囲設定
    Dim Src As Range: Set Src = Range("F2:K2")      '都道府県の検索範囲設定
    Dim Arr As Variant, C As Long, R As Long, N As Long, Rng As Range, Pos As Range
    Arr = Tbl.Value                                                 '枠内データの配列へ
    Tbl.ClearContents: Tbl.Interior.ColorIndex = xlNone             '枠内をクリア
    For C = LBound(Arr, 2) To UBound(Arr, 2)                        '3列分のループ
        Set Pos = Tbl(1).Offset(, C - 1)                            '貼り付け位置の設定
        For R = LBound(Arr, 1) To UBound(Arr, 1)                    '27行分のループ
            Set Rng = Src.Find(Arr(R, C), LookAt:=xlWhole)          '都道府県の検索
            If Not Rng Is Nothing Then                              '見付かったら、
                N = Cells(Rows.Count, Rng.Column).End(xlUp).Row - Rng.Row + 1
                                                                    'コピー行数を取得
                Rng.Resize(N).Copy Pos                              'コピー＆貼り付け
                Set Pos = Pos.Offset(N + 2)                         '次の貼り付け位置
                If Intersect(Tbl, Pos) Is Nothing Then Exit For     '枠外なら次の列へ
            End If
        Next R
    Next C
End Sub

投稿者 : めしばな     投稿日時 : 2025/06/11(Wed) 01:36:52

---

てらてら様。

こちらの拙い説明にわざわざコード作成くださり、ありがとうございます。

投稿者 : めしばな     投稿日時 : 2025/06/11(Wed) 01:39:50

---

ピロリ様。

こちらの拙い説明にコード作成いただき、ありがとうございます。
まさに欲しかったコードでした。
すごいです。本当にありがとうございました。