色のないセルの行削除

質問

任意の色で塗りつぶされたセルがあって、塗りつぶされたセルが存在する行を削除するマクロ。

Sub 行削除()
Dim r As Integer
Dim c As Integer

For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
　　For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
　　　　If Cells(r, c).Interior.ColorIndex <> xlNone Then
　　　　　　　Rows(r).Delete
　　　　End If
　　Next
Next
End Sub

この逆のことがしたいのですが、わかりません。
ちなみにこのプログラムはそのままＣ＆Ｐです。
内容もあまり理解できていません。(^_^;)
添付画像の逆に色のついた行だけ残したいです。

よろしくお願いします

回答No.5

HohoPapa · ベストアンサー

>うまくいきましたが、タイトル行まで削除されました

ありゃ、ごめんなさい。
直します。

Sub 行削除()

　Dim r As Integer
　Dim c As Integer
　Dim DelFlg As Boolean　'行削除フラグ

　For r = ActiveSheet.UsedRange.Rows.Count To 2 Step -1

　　DelFlg = True
　　For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
　　　If Cells(r, c).Interior.ColorIndex <> xlNone Then
　　　　DelFlg = False
　　　　Exit For
　　　End If
　　Next

　　If DelFlg = True Then
　　　Rows(r).Delete
　　End If

　Next

End Sub

お礼

ありがとうございます。　For r = ActiveSheet.UsedRange.Rows.Count To 2 Step -1のところがTo２になったんですね？
検証してみます。

回答No.7

kkkkkm

表をA1から始めるとも限らないとすれば以下のようにしてもいいかもです。

Sub 行削除色あり残す()
Dim r As Integer
Dim c As Integer

For r = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row _
To ActiveSheet.UsedRange.Row + 1 Step -1
For c = ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column _
To ActiveSheet.UsedRange.Column Step -1
If Cells(r, c).Interior.ColorIndex <> xlNone Then
Exit For
End If
If c = ActiveSheet.UsedRange.Column Then
Rows(r).Delete
End If
Next
Next
End Sub

お礼

ありがとうございます。動きを見ながら検証してみます。

回答No.6

skydaddy

＃１です
最初のものは行全体に色がつけられてあるか、１列のフォーマットしか対応しませんでした。
修正を加えた下記で動くと思います。（当方ではうまくいきました）
ただし、背景色の無いセルが白のバックグランドである場合は残されます。
白も消したい時は、
If Cells(r, c).Interior.ColorIndex <> xlNone Thenの行を
If Cells(r, c).Interior.ColorIndex <> xlNone AND Cells(r, c).Interior.ColorIndex <> 2 Thenとしてください。

Sub 色なし行削除()
Dim r As Integer
Dim c As Integer
Dim flag As Boolean

For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
flag = False
For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If Cells(r, c).Interior.ColorIndex <> xlNone Then
flag = True
End If
Next
If flag = False Then Rows(r).Delete
Next
End Sub

お礼

ありがとうございます。またコピペして検証してみます

回答No.4

kkkkkm

こういうのも

Sub 行削除色あり残す()
Dim r As Integer
Dim c As Integer

For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If Cells(r, c).Interior.ColorIndex <> xlNone Then
Exit For
End If
If c = 1 Then
Rows(r).Delete
End If
Next
Next
End Sub

お礼

ありがとうございます。コピペして検証してみます。

回答No.3

imogasi

Sub test01()
lr = Range("A100000").End(xlUp).Row
MsgBox lr
rc = Range("xf2").End(xlToLeft).Column
MsgBox rc
'--
For i = lr To 2 Step -1 '最下の行からの方向行に繰り返す
For j = 1 To rc
'.Interior.ColorIndexが xlNone　　でなければ、塗りつぶしあり、として行削除
If Cells(i, j).Interior.ColorIndex <> xlNone Then
Rows(i).EntireRow.Delete
Exit For
End If
Next j
Next i
End Sub
このやり方は
最下の行からの方向行に繰り返す
が要点です。
質問者のケースの場合、
.Interior.ColorIndexが xlNoneで,ない、で「塗りつぶしあり」が捉えられるケースかどうか、が心配ですが。
やってみてください。

お礼

ありがとうございます。動きを見ながら、関数などを調べながら確認してみます。ＶＢＡ初心者なので皆さんのＶＢＡをコピペしながら覚えてます。

補足

すみません、lr = Range("A100000").End(xlUp).Rowのところでいきなりエラーでとまりました。

回答No.2

HohoPapa

私だったら、次のようにフラグを使います。

Sub 行削除()

　Dim r As Integer
　Dim c As Integer
　Dim DelFlg As Boolean　'行削除フラグ

　For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1

　　DelFlg = True
　　For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
　　　If Cells(r, c).Interior.ColorIndex <> xlNone Then
　　　　DelFlg = False
　　　　Exit For
　　　End If
　　Next

　　If DelFlg = True Then
　　　Rows(r).Delete
　　End If

　Next

End Sub

お礼

ありがとうございます。動きを見ながら、関数などを調べながら確認してみます。ＶＢＡ初心者なので皆さんのＶＢＡをコピペしながら覚えてます。

補足

うまくいきましたが、タイトル行まで削除されました

回答No.1

skydaddy

Sub 行削除_色なし()
Dim r As Integer
Dim c As Integer

For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
　　For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
　　　　If Cells(r, c).Interior.ColorIndex = xlNone Then '<>を=に変換して色なしを削除
　　　　　　　Rows(r).Delete
　　　　End If
　　Next
Next
End Sub

お礼

ありがとうございます。動きを見ながら、関数などを調べながら確認してみます。ＶＢＡ初心者なので皆さんのＶＢＡをコピペしながら覚えてます。

補足

コピペして実行したら全ての行が消えてしまいました。