マクロ・テーブルの色のついた列だけコピーしたい

質問

Excelマクロで悩んでいます。どのように書いたらいいかご教授ください。

■実行したい内容
添付の画像をご参照いただければと思いますが、指定したテーブルの色のついた行だけを別のシートにコピーしたいです。

■補足
・添付の画像では行数を16程度にしていますが実際に使いたい内容では1000行近くあるのと、同シート内でコピーしてほしくない列もあるため、テーブルで指定しています。（図でA～G列はコピー対象だけどH以降は色がついていてもコピー対象外）
ですのでテーブルとしていますが、セル指定での範囲選択でなければできない、という話であればそこにはこだわりません。
・図の結果にあるように、「フォルダB-userB-△」のように、必ず行はセットで転記したいです。
自分で調べてかいた内容では、どうしても「フォルダB-userF-〇」のように、上に詰めて転記されてしまいました。「フォルダBに色をつけたらB～G列すべて色がつく」ようにすれば自分が書いた内容でも対処はできると思いますが、それでは（やりたい内容上）意味がないので、ご相談した次第です。

よろしくお願いします。

回答No.1

kkkkkm · ベストアンサー

A列に必ず色がついている行を行ごとコピーするのでしたら

Sub Test()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, LastRow1 As Long, LastRow2 As Long

Application.ScreenUpdating = False

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet1結果")

LastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow1
If Ws1.Cells(i, "A").Interior.ColorIndex <> xlNone Then
LastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row
Ws1.Cells(i, "A").Resize(1, 7).Copy Ws2.Cells(LastRow2 + 1, "A")
End If
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

Application.ScreenUpdating = True

End Sub

お礼

早々にご回答いただきありがとうございました！いただいた内容を参考に実際のシート側で組み、無事に望みの通りの動きをしてくれました。大変ありがたかったです。
複数ご回答いただきましたが、今回の希望に最も適した内容が一つ目のご回答でしたのでこちらをベストアンサーとさせていただきました。

ちなみに、これは今後検索されている方向けの情報になりますが、今回セルへの色付けは条件付き書式を使っており、「If Ws1.Cells(i, "A").Interior.ColorIndex <> xlNone Then」の部分を「If Ws1.Cells(i, "A").DisplayFormat.Interior.ColorIndex <> xlNone Then」とすることでそれもカウント対象となります。
（これは私の質問内容の不足が原因なので回答者さまにはなにひとつ不足はありませんでした！）

回答No.4

kkkkkm

A列の色とは無関係に行中に一つでもセルに色がついていたらその行をコピーするのでしたら
(No.2はセルのみでしたがこれは行ごとになります。No.1No.2とこれはどの方法もG列まででテーブルは無しでテストしてます)

Sub Test3()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, LastRow1 As Long, LastRow2 As Long
Dim flg As Boolean

Application.ScreenUpdating = False

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet1結果")

LastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
LastRow2 = 2

For i = 2 To LastRow1
flg = False
For j = 1 To Columns("G").Column
If Ws1.Cells(i, j).Interior.ColorIndex <> xlNone Then
flg = True
Ws1.Cells(i, "A").Resize(1, 7).Copy Ws2.Cells(LastRow2, "A")
Exit For
End If
Next
If flg = True Then
LastRow2 = LastRow2 + 1
End If
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

Application.ScreenUpdating = True

End Sub

回答No.3

kkkkkm

回答No.2の訂正です。

訂正忘れてました。

Ws2.Range(Cells(2, "A"), Cells(LastRow2 - 1, "G")).Borders.LineStyle = xlContinuous

は以下に変更してください。

Ws2.Range(Ws2.Cells(2, "A"), Ws2.Cells(LastRow2 - 1, "G")).Borders.LineStyle = xlContinuous

回答No.2

kkkkkm

A列の色とは無関係に色のついているセルだけ列位置を合わせてコピーしたいのでしたら

Sub Test2()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, LastRow1 As Long, LastRow2 As Long
Dim flg As Boolean

Application.ScreenUpdating = False

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet1結果")

LastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
LastRow2 = 2

For i = 2 To LastRow1
flg = False
For j = 1 To Columns("G").Column
If Ws1.Cells(i, j).Interior.ColorIndex <> xlNone Then
flg = True
Ws1.Cells(i, j).Copy Ws2.Cells(LastRow2, j)
End If
Next
If flg = True Then
LastRow2 = LastRow2 + 1
End If
Next

Ws2.Range(Cells(2, "A"), Cells(LastRow2 - 1, "G")).Borders.LineStyle = xlContinuous

Set Ws1 = Nothing
Set Ws2 = Nothing

Application.ScreenUpdating = True

End Sub