VBA オートフィルターと条件分岐による転記

Question

前提・実現したいこと

ﾘｽﾄ表ｼｰﾄ Aﾊﾟﾀｰﾝ列(ｾﾙA7以降)の"○"印になっているｺｰﾄﾞ名(ｾﾙD7以降)を、ﾘｽﾄAﾊﾟﾀｰﾝｼｰﾄのｾﾙH16以降へ転記させたいです。
＜条件＞
ﾘｽﾄAﾊﾟﾀｰﾝｼｰﾄは、ｾﾙH16〜H36とH54〜H74の2つに転記先があります。
条件式で、ﾘｽﾄ表ｼｰﾄ"○"印が21個以下ならｾﾙH16〜H36へ転記させ、
ﾘｽﾄ表ｼｰﾄ"○"印が22個以上ならｾﾙH16〜H36とH54〜H74へ転記させたいです。

該当ソースコード

Sub 転記()
Dim list As Worksheet 'ﾘｽﾄ表　宣言
Dim listA As Worksheet 'ﾘｽﾄAﾊﾟﾀｰﾝ　宣言
Dim listB As Worksheet 'ﾘｽﾄBﾊﾟﾀｰﾝ　宣言
Dim code As Integer 'ｺｰﾄﾞ　宣言
Dim name As Integer '名称　宣言
Dim A As Range 'Aﾊﾟﾀｰﾝ　宣言
Dim B As Range 'Bﾊﾟﾀｰﾝ　宣言
Dim kazuA As Integer 'ﾘｽﾄ表○印の行数
Dim Alline As Integer 'ﾘｽﾄ表のA列最終行
Dim Blline As Integer 'ﾘｽﾄ表のB列最終行

Set list = Worksheets("リスト表")
Set listA = Worksheets("リストＡパターン")
Set listB = Worksheets("リストＡパターン")

list.Range("A6").AutoFilter field:=1, Criteria1:="○"
'オートフィルタでＡ列を○でソート
kazuA = list.Range(Range("A7"), Cells(Rows.Count, 1).End(xlUp)) _
.SpecialCells(xlCellTypeVisible).Count
'○印の行数をｶｳﾝﾄ

If kazuA <= 21 Then
'○印の数が21以下なら以下処理
listA.Range("H17:H36").Value = list.Range("D7:D27").Value
'listの○印のｺｰﾄﾞをlistAのH17からH36へ転記
Else
'22以上なら以下処理
listA.Range("H17:H36").Value = list.Range("D7:D27").Value
'listの○印のｺｰﾄﾞをlistAのH17からH36へ転記
listA.Range("H54:H74").Value = list.Range("D54:D74").Value
'listの○印のｺｰﾄﾞをlistAのH54からH74へ転記

End If

list.ShowAllData
'オートフィルタ解除

End Sub

試したこと

ﾘｽﾄ表ｼｰﾄからｵｰﾄﾌｨﾙﾀｰで"○"印の数はｶｳﾝﾄ出来たのですが、ﾘｽﾄAﾊﾟﾀｰﾝへ転記する際に
＜前提・実現したい事＞で記載してある条件式が機能せず、転記された為、
どのようなｺｰﾄﾞを書けば、達成できるのか教えていただけないでしょうか？

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Answer 1

コピー元が飛び飛びだと、「一括で」っていうのは難しいです。
表を並び替えて、固めてからコピペするか、
作業用のシートに一旦抽出してから、
コピペする方が簡単かな。
あとは個々にコピペするか。

サンプルコードが必要ですか？

---

追記

セルを順次個々にみて転記していくサンプルです。

Sub test_A()
    Dim rngCopyFrom As Range    '複写元セル範囲
    Dim rngCopyTo As Range      '貼付先セル範囲
    Dim c As Range              '各セル
    Dim ixRow As Long           '行の番号（相対位置）
    Dim ixArea As Long          '矩形の番号
    
    '前提条件の定義
    With Worksheets("リスト表").Range("A6").CurrentRegion
        Set rngCopyFrom = Intersect(.Cells, .Offset(1))
    End With
    Set rngCopyTo = Worksheets("リストＡパターン").Range("H16:H36,H54:H74")
    
    ixArea = 1      'コピー先矩形の番号(初期値)
    '1列目の各セルを順次見て行く
    For Each c In rngCopyFrom.Columns(1).Cells
        'もし、今見ているセルが〇なら、
        If c.Value = "○" Then
            ixRow = ixRow + 1   '次の貼付先行番号の用意
            'もし、貼り付け先行番号が21を越えたら、変数を次の矩形用に初期化
            If ixRow > 21 Then
                ixArea = ixArea + 1
                ixRow = 1
            End If
            '見ているセルの3列右を貼り付け先のixArea番目の矩形のixRow番目の行にコピペ
            c.Offset(, 3).Copy rngCopyTo.Areas(ixArea).Cells(ixRow, 1)
        End If
    Next
End Sub

操作対象はセルなので、変数はRange型を用意しておけば、
ワークシート用の変数は必要ないです。
1回変数に、「ここのシートの、このセル範囲」と入れておけば、
どこのシートに所属しているか、情報を持っています。

あと、並び替えを使った例や、オートフィルターを使った例もサンプル書きますか？
もう、おなかいっぱいですか？
並び替えを使ったら処理速度が速いと思いますが、
行数が知れているので、体感で違いが解らないかもしれませんね。

あ、値のみ転記でしたね。
それくらいの変更は、ご自分でチャレンジしていただきたいかな。
勉強なので。

Comments

[jabe]

早速の回答ありがとうございます。

はい、お手数お掛けしますがサンプルコードをいただきたいです。

[jabe]

サンプルコードありがとうございます。
CurrentRegion、Intersect、ixAreaと初めて見るｺｰﾄﾞでお腹いっぱいになりました。動作したところ目的通り動きました。頂いたコードで勉強します。

その中で質問なのですが、転記先のﾘｽﾄAﾊﾟﾀｰﾝｼｰﾄH16〜H36のセルですが、
H16〜N16を1つｾﾙ(結合状態)とした場合に、ｺﾋﾟﾍﾟｺｰﾄﾞで"実行時ｴﾗｰ1004:この操作は結合したｾﾙには行えません"とｴﾗｰが出てしまったのですが、こちらはどのようにしたら解決できるのか教えてください。

[mattuwan]

valueプロパティを、使って値を渡してください。

[jabe]

アドバイスありがとうございます。

はい、頑張ってみます。

[jabe]

”あ、値のみ転記でしたね。”の値のみとはどういう意味でしょうか？
頂いたｺｰﾄﾞを実行したところ転記出来ていたのでどういう意味か分からなくて。

[mattuwan]

「セル」という存在は、値だけを保管してるのではなくフォントや塗りつぶしの色、罫線の有無等、様々な情報により構成されています。
なので、単純にコピペすると、それら全部が複写されます。なので、結合セルに張り付けようとすると、エラーになったり、結合が崩れたりします。
valueプロパティは、そのさまざまな情報の内の「値」の項目ですので、valueプロパティだけを指定して値を渡すようにすると、その他の項目には影響しません。
詳しくは、明日以降にさせてください。パソコンがない環境なので。

[jabe]

説明ありがとうございます。
ｺﾋﾟﾍﾟとvalueの違いが分かりました。

ｺｰﾄﾞを以下のように変更したら動作しました。
rngCopyTo.Areas(ixArea).Cells(ixRow, 1).Value = c.Offset(, 3).Value