[[20170301115948]]　『表全体にある色つきセルだけを取り出す』（ぴーこ）　ページの最後に飛ぶ

『表全体にある色つきセルだけを取り出す』（ぴーこ）

こんにちは。
分かる方がいれば教えてください。

A1:I4000前後(行の数は変動します)の表があります。
その中に黄と赤の塗りつぶしセルがまばらに多数あります。

やりたいことを簡潔に言うと、要約どうり
「表全体にある色つきセルだけを取り出したい」です。

1つの列に色フィルターをかけてしまうと
その列しか色セルはでてきてくれませんよね。
他の列にあった色つきセルは
フィルターをかけたところに色セルがないともちろん出てきません…

なんか対策を考えていたのですが
頭が固いのか、どうも思いつきません・・・

しかし、ふと考え付いたのは、

2行目から最終行までの行に
塗りつぶしセルがなかったら行を削除、または非表示
を繰り返すのはいいんじゃないかと。

でも、VBA習いたての私には
どのようにコードを書けばいいか分かりません。。。

恐縮ですが、コードを教えていただけないでしょうか？

無理なお願いかと思いますが
お力をください。

よろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 何を悩んでるかよく分かんないですが
 「表全体にある色つきセルだけを取り出したい」で、
 削除とかしていいなら
 表全体を指定して、色がついてないセルを削除すればいいだけじゃないですか？

 取り出すといっても、どこのシートのどこに取り出すだとか
 具体例があったほうが回答者も答えやすいと思いますよ
（nazo） 2017/03/01(水) 14:17

分かりづらくてすみません…

手順としては

結果シートをコピーして、抽出シートに貼り付け、
抽出シートのA8をセレクトしてCtrl＋→、Ctrl＋↓で表全体を指定、
色がついてないセル（塗りつぶしなしセル）を削除

こんな感じです。
よろしくお願いします。
（ぴーこ） 2017/03/01(水) 14:29

ども＾＾
ぴーこさんとかぶりましたが。。。

処理前、

         [A]     [B]     [C]     [D]     [E]     [F]    
      ┌───┬───┬───┬───┬───┬───┐
   [1]│項目1 │項目2 │項目3 │項目4 │項目5 │項目6 │
      ├───┼───┼───┼───┼───┼───┤
   [2]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [3]│  赤  │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [4]│      │  黄  │      │      │  赤  │      │
      ├───┼───┼───┼───┼───┼───┤
   [5]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [6]│      │      │      │  黄  │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [7]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [8]│      │      │  赤  │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [9]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
  [10]│      │      │      │      │      │  黄  │
      └───┴───┴───┴───┴───┴───┘

こんな感じですよね？

オートフィルターを掛けて

 全部の列で色フィルターの塗りつぶしなしを選んで、

         [A]     [B]     [C]     [D]     [E]     [F]    
      ┌───┬───┬───┬───┬───┬───┐
   [1]│項目1 │項目2 │項目3 │項目4 │項目5 │項目6 │
      ├───┼───┼───┼───┼───┼───┤
   [2]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [5]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [7]│      │      │      │      │      │      │
      ├───┼───┼───┼───┼───┼───┤
   [9]│      │      │      │      │      │      │
      └───┴───┴───┴───┴───┴───┘

こうなると思うので、
表示されている行を削除

で、オートフィルター解除で行けると思います。

（まっつわん） 2017/03/01(水) 14:47

あぁ、ぴーこさんが質問者さんでしたか＾＾；；失礼しました。

＞でも、VBA習いたての私には
＞どのようにコードを書けばいいか分かりません。。。

とりあえず、手順が解っているなら、
マクロの記録をして、コードを探るところから始めたらいいと思います。

（まっつわん） 2017/03/01(水) 15:04

まっつわん様

やりたいことは、仰っていた通りです！

マクロの記録をしてみました。

↓↓↓

Sub Macro1()

    Range("A7").Select

    ActiveSheet.Range("$A$7:$I$12056").AutoFilter Field:=1, Operator:= _
        xlFilterNoFill
    ActiveSheet.Range("$A$7:$I$12056").AutoFilter Field:=2, Operator:= _
        xlFilterNoFill
    ActiveSheet.Range("$A$7:$I$12056").AutoFilter Field:=3, Operator:= _
        xlFilterNoFill
    ActiveSheet.Range("$A$7:$I$12056").AutoFilter Field:=5, Operator:= _
        xlFilterNoFill
    ActiveSheet.Range("$A$7:$I$12056").AutoFilter Field:=7, Operator:= _
        xlFilterNoFill
    ActiveSheet.Range("$A$7:$I$12056").AutoFilter Field:=9

    Rows("71:71").Select

    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

    Range("A7").Select
    Selection.AutoFilter

End Sub

列で塗りつぶしなしを選択する時に、
Field:=4、Field:=6、Field:=8、
が塗りつぶしセルがなかったのですが、
このような場合どうやってループ？するんでしょう？

（ぴーこ） 2017/03/01(水) 15:13

＞塗りつぶしセルがなかったのですが、
＞このような場合どうやってループ？するんでしょう？

んー。考えてても進まないのでとりあえずやってみる＾＾

Sub Macro1()

    Dim i As Long

    Sheets("Sheet1").UsedRange.Copy Sheets("Sheet2").Range("A1")

    With Sheets("Sheet2").UsedRange
        For i = 1 To .Columns.Count
            .AutoFilter Field:=i, Operator:=xlFilterNoFill
        Next
        .Offset(1).Delete Shift:=xlUp
        .AutoFilter
    End With
End Sub
（まっつわん） 2017/03/01(水) 15:29

まっつわん様

コードの書き込みありがとうございます。

Aから最終列までフィルターをかけ終えた後、
↓↓
.AutoFilter Field:=i, Operator:=xlFilterNoFill

この部分で
「実行時エラー'1004':
RangeクラスのAuto Filterメゾットが失敗しました」
とエラーメッセージが出て来たのですが、
何が原因で止まってしまったんでしょうか＞＜
（ぴーこ） 2017/03/01(水) 15:54

 出遅れているかもしれませんが。

 ・なにかを行う対象は　セル　ですか、その行　ですか？
 ・その　なにか　とは　削除　ですか？　非表示　ですか？
 ・対象は　色付きを　ですか？　色なしを　ですか？

（β） 2017/03/01(水) 16:36

＞Aから最終列までフィルターをかけ終えた後、

なら、

.AutoFilter Field:=i, Operator:=xlFilterNoFill
はもう実行されないはずなので、、、、

ちょっとこちらでは想像できないです。

ステップ実行してiの値をローカルウィンドウで確認してみて、
えらーで止待った時のiの値を教えてください。

（まっつわん） 2017/03/01(水) 16:45

あ、該当なしの時の例外処理を忘れていたので追加しました。
m(_ _)m

Sub Macro1()

    Dim i As Long
    Sheets("Sheet1").UsedRange.Copy Sheets("Sheet2").Range("A1")
    With Sheets("Sheet2").UsedRange
        For i = 1 To .Columns.Count
            .AutoFilter Field:=i, Operator:=xlFilterNoFill
        Next
        If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            .Offset(1).Delete Shift:=xlUp
        End If
        .AutoFilter
    End With
End Sub
（まっつわん） 2017/03/01(水) 16:51

まっつわん様

上記のコードで実行してみましたが

.AutoFilter Field:=i, Operator:=xlFilterNoFill
で止まってしまいます＞＜

ローカルウィンドウで値を確認したところ、
値が10になっていました。

（ぴーこ） 2017/03/01(水) 17:07

＞Sheets("Sheet2").UsedRange

Sheets("Sheet2").UsedRange.resize(,9)
にしてください。

10列目にタイトルがないのかなと想像します。

（まっつわん） 2017/03/01(水) 17:27

 >まっつわん さん

 〓＞Sheets("Sheet2").UsedRange 
 〓Sheets("Sheet2").UsedRange.resize(,9) 
 〓にしてください。

　の変更をしなくても、Sheet1のA1に何か文字列を入れておけば、いいのかも？
（マリオ） 2017/03/01(水) 18:56

 オートフィルターが本線でしょうし、（β） 2017/03/01(水) 16:36 の質問にも答えていただいてないので
 お邪魔虫でしょうけど、皆さんの回答コードを見ると、色なし行を削除する（色付きセルがある行を残す）ということらしいので
 天邪鬼ですが、あえて、コテコテループで。

 領域の特定の書式の値を取得した時に、その値が混在なら NULL、すべてのセルが同じ値なら、その値が戻される特性を利用して
 行単位に処理しています。

 Sub Sample()
    Dim r As Range
    Dim a As Range
    Dim ck As Variant

    With ActiveSheet.UsedRange.Columns("A:I")
        For Each r In Intersect(.Cells, .Offset(1)).Rows
            ck = r.Interior.ColorIndex
            If ck = xlNone Then
                If a Is Nothing Then
                    Set a = r
                Else
                    Set a = Union(a, r)
                End If
            End If
        Next
    End With

    If Not a Is Nothing Then a.Delete xlUp

 End Sub

（β） 2017/03/02(木) 00:34

　の変更をしなくても、Sheet1のA1に何か文字列を入れておけば、いいのかも？

iが10まで進んでいるので、A1にはタイトル行とみなせる何かがありそうです。
むしろ、

＞A1:I4000前後(行の数は変動します)の表
だから、9列だと明示することで、エラーは回避できるはずですが、
シートが見れないので、オートフィルターが失敗する原因が特定できないですねー。。。

（まっつわん） 2017/03/02(木) 07:51

（まっつわん）様
（マリオ）様
（β）様

お返事遅れて申し訳ありません。
（まっつわん）様のコードでも（β）様のコードでも
動作がスムーズに通りました！！

（β）様、2017/03/01(水) 16:36 の質問スルーしてすみません。
悪気があってスルーしたわけではありませんのでお許しください。

この度はVBA初心者な私に親切にご回答いただき
誠にありがとうございました。
いつか皆様のような回答者になれるくらいの実力を身につけていきたいと思います。

本当にありがとうございました＞＜
（ぴーこ） 2017/03/02(木) 09:12

コメント返信：

[ 一覧(最新更新順) ]

[[20170301115948]] 『表全体にある色つきセルだけを取り出す』（ぴーこ） ページの最後に飛ぶ

[[20170301115948]]　『表全体にある色つきセルだけを取り出す』（ぴーこ）　ページの最後に飛ぶ