塗りつぶしプロパティの判定でエラーが出る

質問

上司（上司A）がエクセルで作業予定表を作っております（添付画像の体裁です。実際はもっと日数や予定数があります）。
別の上司から、このエクセルの情報を一覧として別シートに抽出するよう指示されました。
一覧の形式としては、A列に作業開始日、B列に作業者名、C列に作業継続日数、と並べて記載し、作業割り当て者の無い日は抽出不要、です。

作業開始日、作業者の抽出自体はさして難しくありませんでしたが、作業継続日数は少々やっかいでした。
というのも上司Aの作業予定表では、作業者の作業継続状況をセルの塗りつぶしで表示しており、ここで終わり、という文字なり記号なりがあるわけでは無かったためです。

そこで、セルのプロパティで塗りつぶし状態をみて、それにより作業終了日を判定しようと考えました。
また、作業終了日翌日から別の作業が続いている場合はこれで判定出来ないため、空欄であること、という条件も追加しました。

以上を考え作成したコードですが、塗りつぶし判定のところでエラーが発生してしまいます。

エラーは、

　　実行時エラー　1004
　　アプリケーション定義またはオブジェクト定義のエラーです。

です。

試しに、「<>」を「=」にしてみたところ通ります。
（ただし望んだ結果は得られません。当然ながら……）

いったい何が問題か、どなたかアドバイス頂けませんでしょうか……。

-----以下コード-----

Option Explicit

Sub スケジュール抽出()

Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long

k = 1

For i = 2 To 11
For j = 1 To 4
If Not Cells(j, i) = "" Then
If Not j = 1 Then
Worksheets("Sheet2").Cells(k, 2).Value = Cells(j, i).Value

l = i
Do While Cells(j, l).Interior.ColorIndex <> xlColorIndexNone Or Cells(j, l).Value = ""　←ここでエラー
' Do While Cells(j, l).Interior.ColorIndex = xlColorIndexNone Or Cells(j, l).Value = ""　←こうするとエラーは起きない
l = l + 1
Loop
m = l - i
Worksheets("Sheet2").Cells(k, 3).Value = m '予定の継続日数

Else
Worksheets("Sheet2").Cells(k, 1).Value = Cells(j, i).Value
k = k + 1
End If
End If
Next
Next

MsgBox "抽出完了"

End Sub

回答No.4

real beatin（@realbeatin） · ベストアンサー

＃１,３です。

＃３の直接の回答の修正点は少し違っていたみたいなので、
あらためて、当初のお望みは、こういうことかな？という
コードを実際に動くような形であげてみますね。
＃１-３のコードとの違いを言えば、何がなんでもデータ範囲すべてをループする、
ので、少し無駄な感じがしますし、
全セルループの内側で、DoLoopでセル範囲のループを重ねるのも少し違和感はあります。
でも、ロジックとしてこれはこれで成立していますね。

まぁ、入力に際しての規則に対して、
不規則なものへの手当てを何処まで考慮に入れて、
それらへのエラー（回避）対策を何処まで書くか、
という点については、
本来、メンテナンスレベルでのタスクですから、
不足があるかも知れないですし、これで十分なのかも知れないですし、
現場での判断に委ねるとして、今の処こちらからは何とも言えません。
最終的にどんな記述を選ぶにせよ、せっかくですから、
ご提示の記述も動くようにしてから、納得の上、次に進んだ方が好いのかな、
と改めて思い直しました。

以下、質問添付画像の場合は、＃１,３と同じデータを同じ並びで返します。
＃３添付画像の例では、それぞれ違う結果になります。

' ' ///

Sub スケジュール抽出_re()
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
　　Sheets("Sheet1").Select
　　k = 0
　　For i = 2 To Cells(1, 2).End(xlToRight).Column
　　　　For j = 2 To Cells(2, 1).End(xlDown).Row
　　　　　　If Cells(j, i) <> "" Then
　　　　　　　　k = k + 1
　　　　　　　　l = i
　　　　　　　　Do While Cells(j, l + 1).Interior.ColorIndex <> xlColorIndexNone And Cells(j, l + 1).Value = ""
　　　　　　　　　　l = l + 1
　　　　　　　　Loop
　　　　　　　　m = l - i + 1
　　　　　　　　Worksheets("Sheet2").Cells(k, 1).Value = Cells(1, i).Value　'　作業開始日
　　　　　　　　Worksheets("Sheet2").Cells(k, 2).Value = Cells(j, i).Value　'　作業者名
　　　　　　　　Worksheets("Sheet2").Cells(k, 3).Value = m　'　予定の継続日数
　　　　　　End If
　　　　Next
　　Next
　　Sheets("Sheet2").Select
　　MsgBox "抽出完了"
End Sub

' ' ///

お礼

こんにちは。
休出（汗）を終え帰宅したところ、素晴らしいご回答を頂いており、小躍りしております。
塗りつぶし無しで判定……の意図はご拝察の通りです。
最初に書いておくべきでしたね（汗）

また、二種類もの正解サンプルを頂戴でき、大変勉強になります。
エクセル（VBA）の作法というか、効率の良いコーディングがどういったものかまだ全然理解していない初心者なので、いろいろムズムズされたかと存じますが、丁寧にお付き合いいただき感謝の至りです。

最初のサンプルもしっかり拝見して、勉強させて頂きたいと思います。
ありがとうございました。

補足

あ、エラーの原因についてですが、単なるロジックバグだったのですね、お恥ずかしい限りです……。
高校二年で数学を諦めたクチなので、AND とか OR の辺りはちょっと考えるとたちまち混乱してしまうのがこんな所にも現れてしまい（汗）

回答No.3

real beatin（@realbeatin）

＃１です。

"上司さん（他人）のやることだから塗り潰しも不規則かも知れない。"
というような意味での保険を掛けていくなら、
質問添付画像の例示のようにはならず、
なるほど[作業者名]を跨いで連続して同色で塗り潰しているかも知れませんし、
或いは期間未定とかで、塗ってさえいない場合も考えられますね。
ということで、対策したものを最後に再掲します。
因みに、.ColorIndex ではなく、.Color を条件に使う理由は、
一旦大き目の範囲を塗り潰した後の修正の際に上司さん（他人）が
[塗り潰しなし]ではなく[白]で塗ってしまうかも知れない
ことへの対策になっていたりします。

それから、あらためて直接の回答ですが、
ご提示のコードのエラーは、
ご提示の画像サンプルで言うと、
１件めの[作業者名]田中さんに関する期間処理で、
>　　l = i
>　　Do While Cells(j, l).Interior.ColorIndex <> xlColorIndexNone Or Cells(j, l).Value = ""　' ←ここでエラー
の条件判別が正しくない為に、
２件めの[作業者名]鈴木さんの列でループを止めるような判別が出来ていない
ことが原因です。
現象としては、２行めを 16384 列め（旧バージョンなら 256 列め）
を超えてループしようとしている為に、
Cells(j, 16385)（旧バージョンなら Cells(j, 257)）
という存在しないセルを参照を指定している為に起こる実行時エラーです。
その点に対して部分的な修正をするとすれば、
　　l = i + 1
　　Do While Cells(j, l).Interior.ColorIndex <> xlColorIndexNone And Cells(j, l).Value = ""
のような形になります。
修正点は「 + 1」「 And 」の２ヶ所です。
先述の通り、この部分の修正だけでは十分でありませんが、
今回課題のエラーの原因と対処法については、
納得のいく答え、になっているのではないかと思います。

以下、冒頭で述べた修正（対策）を加えたコード（修正★３ヶ所）です。
有効な範囲の右端列を超えないように条件を加えることで、
塗り潰しされていない場合にも対応します。
なお、余計なこととは思いますが、
Ｄ列に"予定1"～"予定n"を出力する場合を●option 1-3で書き足しています。
不要なら削除して構いませんが、[予定]項目を追加しておくと、
好きな順に並べ替えできるようになるかなぁ、と。

' ' ///

Sub Re8985616w()　'　スケジュール抽出
Dim Target As Range　'　Sheet1 元データ セル範囲
Dim rngPrint As Range　'　Sheet2 出力先 セル範囲
Dim c As Range　'　ループ用 range型変数
Dim nLastColumn As Long　'　有効範囲の右端列位置★
Dim nCurColor As Long　'　基準の背景色
Dim cnDay As Long　'　作業継続日数 カウンタ
Dim k As Long　'　出力行位置 カウンタ

' '　Sheet2
　　Set rngPrint = Sheets("Sheet2").Range("A:C")　'　Sheet2 出力先 セル範囲 を変数に格納　●prime 1
'　　Set rngPrint = Sheets("Sheet2").Range("A:D")　'　Sheet2 出力先 セル範囲 を変数に格納　●option 1
　　rngPrint.Clear　'　Sheet2 出力先 セル範囲 をクリア
　　rngPrint.Rows(1).Value = Split("作業開始日 作業者名 作業継続日数")　'　Sheet2 出力先 セル範囲 項目名 設定　●prime 2
'　　rngPrint.Rows(1).Value = Split("作業開始日 作業者名 作業継続日数 予定")　'　●option 2
　　rngPrint.Columns(1).NumberFormatLocal = "m""月""d""日"""　'　Sheet2 出力先 セル範囲 日付表示形式 設定

' '　Sheet1
　　Sheets("Sheet1").Select
　　Set Target = Cells(2, 2).CurrentRegion.Offset(1, 1)　'　Sheet1 元データ セル範囲 を変数に格納
　　nLastColumn = Target(Target.Count).Column　'　★
　　Set Target = Target.SpecialCells(xlCellTypeConstants)　'　Sheet1 元データ セル範囲 値のあるセルのみ抽出

　　k = 1　'　出力行位置 初期化
　　For Each c In Target　'　Sheet1 元データ セル範囲 値のあるセル を総当たりでループ
　　　　nCurColor = c.Interior.Color　'　基準の背景色を記録
　　　　cnDay = 1　'　作業継続日数 初期化
　　　　' ' ひとつ右のセルの背景色が基準の背景色と一致している間 ループ　★
　　　　Do While c.Offset(, cnDay).Interior.Color = nCurColor And c.Offset(, cnDay) = "" And c.Offset(, cnDay).Column < nLastColumn
　　　　　　cnDay = cnDay + 1　'　作業継続日数をカウント
　　　　Loop
　　　　k = k + 1　'　出力行位置を送り
　　　　' ' 作業開始日 作業者名 作業継続日数 データを出力
　　　　rngPrint.Rows(k).Value = Array(Cells(1, c.Column), c, cnDay)　'　●prime 3
'　　　　rngPrint.Rows(k).Value = Array(Cells(1, c.Column), c, cnDay, Cells(c.Row, 1))　'　＋[予定]●option 3
　　Next

' '　Sheet2
　　Sheets("Sheet2").Select
'' '　作業開始日 の順に ソート
　　rngPrint.Sort Key1:=rngPrint(1, 1), Order1:=xlAscending, Header:=True, Orientation:=xlSortColumns

　　MsgBox "抽出完了"
End Sub

' ' ///

回答No.2

keithin

エラーが出た直接の原因として、不適切なデータが記入されているためと推測します。
あとはまぁ、誰がやっても似たようなマクロの構成になっちゃいますね。

sub macro1()
　dim h as range
　dim Target as range
　dim n as long

’出力準備
　worksheets("Sheet2").range("A:C").clearcontents
　worksheets("Sheet2").range("A1:C1") = array("作業開始日", "作業者名", "作業継続日数")
　worksheets("Sheet2").range("A:A").numberformatlocal = "mm/dd"
　worksheets("Sheet1").select

for each h in range("A1").currentregion.offset(1,1).specialcells(xlcelltypeconstants)

’不適切データチェック（例）
　if h.interior.colorindex = xlnone then
　　h.select
　　msgbox "ERROR"
　　exit sub
　end if

’抽出
　n = 1
　do until h.offset(0, n).interior.color <> h.interior.color or h.offset(0, n) <> ""
　　n = n + 1
　loop

’出力
　with worksheets("Sheet2").range("A65536").end(xlup).offset(1)
　　.offset(0, 0) = cells(1, h.column)
　　.offset(0, 1) = h
　　.offset(0, 2) = n
　end with
　next

end sub

お礼

こんにちは。
正常に作動するサンプルコードをいただき、誠にありがとうございます。
初心者である私の目からは、いかにもエクセルチックな記述がたくさんあって、とても勉強になります。
しっかり拝見させていただきたいと思います。

回答No.1

real beatin（@realbeatin）

こんにちは。

他にもうまく行ってない点もあるようでしたので、
こちらで設計し直したものでお答えします。

1.　[作業者名]の書かれたセルを過不足なく抽出
2.　[作業者名]セルの背景色を基準色として記録
3.　[作業者名]セルから右へ基準色とは違う背景色が見つかるまで
　　[作業継続日数]をカウントしながらループ
4.　[作業開始日] [作業者名] [作業継続日数] データ出力
5.　以上の処理は、[作業者名]セルを　右→、下↓、の順にループするので、
　　最後に、出力先を日付順にソート

といった流れです。
もしお手元のマクロを修正するのでしたら、
2.3.あたりが参考になるのではないでしょうか。

不足や疑問があれば、補足欄にでも書いてみて下さい。

' ' ///

Sub Re8985616w()　'　スケジュール抽出
Dim Target As Range　'　Sheet1 元データ セル範囲
Dim rngPrint As Range　'　Sheet2 出力先 セル範囲
Dim c As Range　'　ループ用 range型変数
Dim nCurColor As Long　'　基準の背景色
Dim cnDay As Long　'　作業継続日数 カウンタ
Dim k As Long　'　出力行位置 カウンタ

' '　Sheet2
　　Set rngPrint = Sheets("Sheet2").Range("A:C")　'　Sheet2 出力先 セル範囲 を変数に格納
　　rngPrint.Clear　'　Sheet2 出力先 セル範囲 をクリア
　　rngPrint.Rows(1).Value = Split("作業開始日 作業者名 作業継続日数")　'　Sheet2 出力先 セル範囲 項目名 設定
　　rngPrint.Columns(1).NumberFormatLocal = "m""月""d""日"""　'　Sheet2 出力先 セル範囲 日付表示形式 設定

' '　Sheet1
　　Sheets("Sheet1").Select
　　Set Target = Cells(2, 2).CurrentRegion.Offset(1, 1)　'　Sheet1 元データ セル範囲 を変数に格納
　　Set Target = Target.SpecialCells(xlCellTypeConstants)　'　Sheet1 元データ セル範囲 値のあるセルのみ抽出

　　k = 1　'　出力行位置 初期化
　　For Each c In Target　'　Sheet1 元データ セル範囲 値のあるセル を総当たりでループ
　　　　nCurColor = c.Interior.Color　'　基準の背景色を記録
　　　　cnDay = 1　'　作業継続日数 初期化
　　　　' ' ひとつ右のセルの背景色が基準の背景色と一致している間 ループ
　　　　Do While c.Offset(, cnDay).Interior.Color = nCurColor
　　　　　　cnDay = cnDay + 1　'　作業継続日数をカウント
　　　　Loop
　　　　k = k + 1　'　出力行位置を送り
　　　　' ' 作業開始日 作業者名 作業継続日数 データを出力
　　　　rngPrint.Rows(k).Value = Array(Cells(1, c.Column), c, cnDay)
　　Next

' '　Sheet2
　　Sheets("Sheet2").Select
' '　作業開始日 の順に ソート
　　rngPrint.Sort Key1:=rngPrint(1, 1), Order1:=xlAscending, Header:=True, Orientation:=xlSortColumns

　　MsgBox "抽出完了"
End Sub

' ' ///