【Excel VBA】色のついたセルがある行を別シートにコピペする方法

Question

はじめまして。VBA勉強中の者です。
色々調べてみたのですが、うまくいかず・・・ご教授頂けないでしょうか。

前提・実現したいこと

この表のAの列が「3.変更」かつ、B～Eに黄色セルが含まれている場合、
対象のB～E行を別シートに上から詰めてコピペしたいのですが、うまくいきません。

●【別シート↓】

↓途中まで考えたものです。（セル等は上記例とは異なります/※7行目から表が始まっています。）

Sub 対象を別シートにコピー()				
    Dim i				
    Dim Sht1 As Worksheet				
    Dim Sht2 As Worksheet				
    				
        Set Sht1 = Sheets("貼付用")				
        Set Sht2 = Sheets("2.変更、3.廃止")				
    				
    				
        For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row				
            				
            If Sht1.Cells(i, 1) = "3.変更" And Sht1.Range(Cells(i, 4), Cells(i, 7)).Interior.ColorIndex = xlNone Then '色潰し無しの場合は何もせず				
          	
        Else				
            Range(Sht1.Cells(i, 4), Sht1.Cells(i, 7)).Copy Destination:=Range(Sht2.Cells(i, 1), Sht2.Cells(i, 4)) 'コピペ				
        End If				
    Next				
    				
End Sub				

参考にしたページ

リンク内容

以上、よろしくお願いいたします。

Comments

[hex309]

どのようなコードを書かれていますか？
現時点のもので結構ですので、コードを提示されたほうが、よろしいかと思います。
また、「うまく行かない」ということですが、エラーメッセージがでるのか、どこがうまくいっていないのか、具体的にされたほうが、回答が付きやすいと思います。

[mattuwan]

色が付いたとありますが、それは条件付き書式設定で色が付いたということでしょうか？それともセルの書式設定で色を付けたということでしょうか？

[knk.k]

mattuwan様
コメントありがとうございます。
条件付き書式設定で色が付いているようです。
（わかりづらくすみません。
表自体は別担当者が作成しており、その後ファイルをもらい、私が編集して該当のものを抽出しようとしています）
よろしくお願いいたします。

[knk.k]

hex309様
コメントありがとうございます。
そうですね、本当のファイルは業務上開示できない為、似たような表を作成しました。
合わせてコードも掲示します。失礼しました。

[hatena19]

現時点でのコードを提示してください。
また、具体的に調べたことを提示してください。
参考にしたページのURLとか。

Answer 1

NG
Sht1.Range(Cells(i, 4), Cells(i, 7))
cellsの親シート指定を省略しない
正
Sht1.Range(Sht1.Cells(i, 4), Sht1.Cells(i, 7))

NG
If Sht1.Range(Cells(i, 4), Cells(i, 7)).Interior.ColorIndex = xlNone Then

複数セルの背景色を一度に取得して判定はできない。

正
ループで一つずつ取得して判定
例えば、For Each を使う

    Dim c As Range
    For Each c In Sht1.Range(Sht1.Cells(i, 2), Sht1.Cells(i, 5))
        If c.Interior.ColorIndex = xlNone Then    '色潰し無しの場合は何もせず
        Else
            'コピー処理
            Exit For
        End If
    Next

NG
Range(Sht1.Cells(i, 4), Sht1.Cells(i, 7)).Copy Destination:=Range(Sht2.Cells(i, 1), Sht2.Cells(i, 4)) 'コピペ
コピー元と同じ行位置(i)に貼り付けている。

正
貼り付け位置用の変数を用意して、コピーするたび1加算する。

Dim j As Long
j = 1


    'コピー処理
    Sht1.Range(Sht1.Cells(i, 4), Sht1.Cells(i, 7)).Copy Destination:=Sht2.Cells(j, 1)    'コピペ
    j = j + 1

上記を考慮して

Sub 対象を別シートにコピー()
    Dim i As Long, j As Long
    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet

    Set Sht1 = Sheets("貼付用")                
    Set Sht2 = Sheets("2.変更、3.廃止")                

    j = 1    '貼付先の開始行
    For i = 2 To Sht1.Cells(Rows.count, 1).End(xlUp).Row
        If Sht1.Cells(i, 1).Value = "3.変更" Then 
            Dim c As Range
            For Each c In Sht1.Range(Sht1.Cells(i, 2), Sht1.Cells(i, 5))
                If c.Interior.ColorIndex <> xlNone Then    '背景色あり
                    Sht1.Range(Sht1.Cells(i, 2), Sht1.Cells(i, 5)).Copy Destination:=Sht2.Cells(j, 1)
                    j = j + 1
                    Exit For
                End If
            Next
        End If
    Next

End Sub

背景色が条件付き書式で設定されている場合も考慮するなら、
If c.Interior.ColorIndex <> xlNone Then
を下記に変更
If c.DisplayFormat.Interior.ColorIndex <> xlNone Then

Comments

[knk.k]

hatena19様

はじめまして。
間違っている部分の細かい修正もありがとうございます。
こちら条件で「A列が「3.変更」」の場合というのを追加したいのですが
どの部分に追加すればよいでしょうか？
「1.新規」や「2.廃止」の場合にもセルに色がついている場合があるので・・・
ご教授のほどよろしくお願いいたします。

[hatena19]

回答のコードに、「A列が「3.変更」」という条件も追加しました。参照ください。

[jinoji]

Exit Forだとループを出てしまいませんか。
VBAには他言語のContinueみたいなことはできないはずなので、
If文で内側のループを囲む感じにするのではないでしょうか。

[knk.k]

hatena19様
コメントありがとうございます。
追加していただいた内容だとうまく反映されず・・・

最初にご教授頂いた文のIF文の前に「Sht1.Cells(i, 1) = "3.変更"」と入れたら
うまくいったのですが、これだと問題ありでしょうか？

If Sht1.Cells(i, 1) = "3.変更" and c.DisplayFormat.Interior.ColorIndex <> xlNone Then '背景色が条件付き書式
（条件付き書式でした）

ご教授頂けると幸いです。

[hatena19]

jinoji様、ご指摘感謝。
そうでした。少しでもコードを短くしようとしてミスりました。
回答のコード修正しておきます。

[hatena19]

knk.k様
そのコードでもOKです。
ただ、Sht1.Cells(i, 1) = "3.変更" の判定が冗長になります。
（気にするほどの差はでないですが）

[knk.k]

hatena19様、jinoji様

ご教授大変感謝します。
無事解決しました！
本当にありがとうございました。
今後ともよろしくお願い致します。