EXCEL 表の編集。特定の項目の抜き出しについて

質問

エクセル初心者です。
添付している画像のように、ランダムな要素で色をつけたセルのある行と列のみを
抜き出す方法はありますでしょうか？
必要な情報は、色をつけたセルの数字と、そのセルの属する日付と店名です。
これらの情報が抜き出せれば、表の形を保っている必要はありません。
ただ、元の表自体を情報が抜き出しやすいような形式に変えることはできないので
あくまで質問の意図は、この表から別の形に加工する方法です。

実は、仕事で使用したいのですが
今現在、手書きでそれらの情報を書き出しているアナログな状況でして
非常に時間がかかり困っております。。。
どなたか、よい方法をご教授いただければと思います。

回答No.2

tom04

こんばんは！
Sheet1にデータがあり、Sheet2に表示するようにしてみました。
Sheet1の1行目・A列は項目行・列とします。

VBAになってしまいますが、一例です。
セルの色は手動で色付けされているとします。

Alt＋F11キー　→　メニュー　→　挿入　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, endCol As Long, wS As Worksheet, myFlg As Boolean
Set wS = Worksheets("Sheet2")
Worksheets("Sheet1").Cells.Copy wS.Range("A1")
endCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
For j = 2 To endCol
myFlg = False
If Cells(i, j).Interior.ColorIndex <> xlNone Then
myFlg = True
Exit For
End If
Next
If myFlg = False Then
wS.Rows(i).Delete
End If
Next i
For j = endCol To 2 Step -1
myFlg = False
For i = 2 To wS.Cells(Rows.Count, j).End(xlUp).Row
If wS.Cells(i, j).Interior.ColorIndex <> xlNone Then
myFlg = True
Exit For
End If
Next i
If myFlg = False Then
Columns(j).Delete
End If
Next j
Application.ScreenUpdating = True
End Sub 'この行まで

こんなんではどうでしょうか？m(_ _)m

回答No.1

MarcoRossiItaly

Excel 2007 以後であれば、セルの塗りつぶしやフォントの色でフィルタがかけられます（参考 URL）。試してください。

＞……元の表自体を情報が抜き出しやすいような形式に変えることはできないので……

シートごとコピーして、そのコピーを好き勝手に加工することさえ許されないのでしょうか？許される場合は、それも検討してください。

上記以外だと、マクロですね。例えばこんな。標準モジュールに貼ってください。

Sub ColoredCells()

　　Dim sh As Worksheet
　　Dim rng As Range
　　Dim cnt As Long

　　Set sh = Worksheets("sheet1")　　'←実際のシート名で「sheet1」を上書き修正

　　Worksheets.Add after:=sh

　　Range("a1").Value = "店名"
　　Range("b1").Value = "日付"
　　Range("c1").Value = "数値"

　　For Each rng In sh.Range("b2:g6")　　'←実際のセル範囲で「b2:g6」を上書き修正
　　　　If rng.Interior.ColorIndex <> xlColorIndexNone Then
　　　　　　cnt = cnt + 1
　　　　　　Cells(cnt + 1, "a").Value = sh.Cells(rng.Row, "a").Value
　　　　　　Cells(cnt + 1, "b").Value = sh.Cells(1, rng.Column).Value
　　　　　　Cells(cnt + 1, "c").Value = rng.Value
　　　　End If
　　Next rng

End Sub

参考URL：

http://www.eurus.dti.ne.jp/~yoneyama/Excel2007/excel2007-filter_col.html