Excelのマクロ作成について

質問

電車の時刻表がありまして
　　Ａ　　　Ｂ　　 　Ｃ　　　　Ｄ　　　　Ｅ　　　　Ｆ　　　　Ｇ　　　　Ｈ　　　　Ｉ　　　　Ｊ　　　　Ｋ　　　　Ｌ　　　　Ｍ　　　　Ｎ
１　
２　あ　　　　　 　1054　　1425　　1555　　1725
３　い　　　0　　　1059　　1430　　1600　　1730
４　う　　　5　　　1104　　1235　　1435　　1505　　1605　　1735
５　え　　　7　　　1105　　1237　　1437　　1507　　1607　　1737
６　お　　　9　　　1108　　1239　　1439　　1509　　1608　　1739
７　か　　　　 　　1110　　1240　　1430　　1440　　1510　　1610　　1740　　1840
８　き
９　く

Ａ列は駅の名前、Ｂ列の数字は０と入力した駅からそれぞれの駅までの平均的な所要時間でＣ列以降は時刻です（：は抜いて対応）

マクロで作りたいことは、
０と書かれた行の時刻を１セルずつ見ていき、そのセルに色を付けます。
次にＢ列の最終行の数字の所までそれぞれ足して合致していいるものがあれば色を塗る。
もし途中で合致しないものがあればその瞬間今まで色を塗っていたものを元の状態（色を塗っていたものを全て真っ白）に戻して次のセルを見ていき、最後のセルまで行う。

上の例の場合
(1)まず０と書かれた行の最初のセルC3を見て確認のため色を付けます。

(2)次にC3とB4の時刻を足して合致するものが４行目にあれば色を付けます。このときC4に1104がありますので色を付けます。

(3)今度はC3とB5の時刻を足して合致するものが５行目にあれば色を付けるのですが、このとき５行目には1106はないので、この瞬間、C3とC4に付けた色をデフォルトの状態にし以降のチェックは行わず、D3のチェックに移ります。

(4)次はD3に移り、Ｃ列同様、D3とB4～B6の時刻を足したものがそれぞれ4行目、5行目、6行目にあるかチェックします。省きますが、全部あるのでD3、E4、E5、E6に色が付き、E3に移ります。

(5)E3も同様に行います。E3とB4～B5の時刻を足して対応したものがそれぞれ3行目、4行目にあるのですが、E3+B6の時刻が6行目には無いのでE3、G4、G5の塗ったセルをもとに戻し、F3に移動します。

(6)F3に移動し以下同様です。対応するものがあるのでF3、H4、H5、H6に色が付き、０と書かれた行の最終行なので処理が終了します。

※Ｂ列の平均所要時間はいつもB3から入れるわけではなく、ケースバイケースで変わってきます。

一応、この例をマクロを使って無事動いた時の画像も載せておきます

といったマクロを作りたいのですが、初心者のため手も足も出ません。
時間もないので、マクロ作成に自信のお有りの方、もしよろしければこれを実装するためのコードを教えて頂けないでしょうか？
丸投げで誠に申し訳ございません。

長文失礼足しました。

回答No.4

n-jun · ベストアンサー

n-junです。

Sub　try()
　Dim　rs　As　Range,　rd　As　Range
　Dim　rc　As　Range,　rf　As　Range
　Dim　rr　As　Range,　ru　As　Range
　Dim　T_c　As　String,　T_r　As　Integer

　Set　rd　=　Range("B:B").SpecialCells(xlCellTypeConstants,　1)
　Set　rd　=　rd.Offset(1).Resize(rd.Rows.Count　-　1)
　Set　rs　=　rd.Item(0)

　For　Each　rc　In　Range(rs.Offset(,　1),　Cells(rs.Row,　Columns.Count).End(xlToLeft))
　　　　　T_c　=　Format(rc.Value,　"00:00")
　　　　　Set　ru　=　rc
　　　　　For　Each　rr　In　rd
　　　　　　　　　T_r　=　Val(Left(Replace(TimeValue(T_c)　+　TimeValue(Format(rr.Value,　"00:00")),　":",　""),　4))
　　　　　　　　　Set　rf　=　rr.Resize(,　20).Find(What:=T_r,　LookIn:=xlValues,　LookAt:=xlWhole)

　　　　　　　　　If　rf　Is　Nothing　Then
　　　　　　　　　　　　Set　ru　=　Nothing:　Exit　For
　　　　　　　　　Else
　　　　　　　　　　　　Set　ru　=　Union(ru,　rf)
　　　　　　　　　End　If
　　　　　Next
　　　　　If　Not　ru　Is　Nothing　Then　ru.Interior.ColorIndex　=　6
　Next
　Set　rd　=　Nothing
　Set　rs　=　Nothing
　Set　rf　=　Nothing
　Set　ru　=　Nothing
End　Sub

Excel2002ですので他のバージョンではわかりませんがご参考程度に。

補足

n-jun様、ありがとうございます。
こちらのバージョンはExcel2007ですが、期待通りの動きをしました。

他のデータでも試してみた所一部、足し合わせた数値があっているにもかかわらず、
０の行の最初の数個分に色が付かないという不具合を発見いたしましたが、
コード13行目の
T_r　=　Val(Left(Replace(TimeValue(T_c)　+　TimeValue(Format(rr.Value,　"00:00")),　":",　""),　4))の
最後の数字を「3」に書き換えたもう一つのマクロ作る事により解決できました。

本当にこんな駄目な自分のためにお付き合いしていただきありがとうございました。

回答No.8

hige_082

＞If Cells(x, y).Text = Format(TimeValue(Format(Cells(x, 2).Value, "00:00")) + TimeValue(Format(Cells(topRow - 1, i).Value, "00:00")), "hhmm") Then
を
If Cells(x, y).Text = Format(TimeValue(Format(Cells(x, 2).Value, "00:00")) + TimeValue(Format(Cells(topRow - 1, i).Value, "00:00")), "hmm") Then
でいけると思います

補足

hige_082様、返答が遅くなり申し訳御座いません。このコードに直したら無事に動きました。ありがとうございます。

これを持ちまして全て解決致しましたので、質問の方は締め切らせて頂きます。
n-jun様、hige_082様誠にありがとうございました。

回答No.7

n-jun

n-junです。

＞T_r　=　Val(Left(Replace(TimeValue(T_c)　+　TimeValue(Format(rr.Value,　"00:00")),　":",　""),　4))の
＞最後の数字を「3」に書き換えたもう一つのマクロ作る事により解決できました。

T_r = Val(Left(Format(Replace(TimeValue(T_c) + TimeValue(Format(rr.Value, "00:00")), ":", ""), "000000"), 4))
こちらで如何でしょう。

補足

n-jun様、何度もありがとうございます。このコードで試した所、＃４で指摘させて頂いたエラーは無くなりました。

もう一つマクロを作成しなくなった分だけスリムになって良かったです。

この度は誠にありがとうございました。

回答No.6

hige_082

いや～n-junさんのコードには何時も感心させられます
私も勉強せねば！

稚拙なコードですが・・・参考になれば

Sub test()
Dim topRow As Long
Dim endRow As Long
Dim x As Integer, y As Integer, z As Integer, i As Integer
Dim a As String
endRow = Range("b65536").End(xlUp).Row
topRow = Cells(endRow, 2).End(xlUp).Row + 1
For i = 3 To Cells(topRow - 1, 3).End(xlToRight).Column
a = Cells(topRow - 1, i).Address
z = 1
For x = topRow To endRow
For y = 3 To Cells(x, 3).End(xlToRight).Column
If Cells(x, y).Text = Format(TimeValue(Format(Cells(x, 2).Value, "00:00")) + TimeValue(Format(Cells(topRow - 1, i).Value, "00:00")), "hhmm") Then
a = a & "," & Cells(x, y).Address
z = z + 1
End If
Next y
Next x
If z = endRow - topRow + 2 Then Range(a).Interior.ColorIndex = 6
Next i
End Sub

補足

hige_082様ありがとうございます。私にとってはhige_082様もn-jun様も感心させられます。

さて、本題の方ですがこのコードを実行したところ、n-jun様の所でも指摘したようなエラーが出ました。

経験から言うと恐らくIf Cells(x, y).Text = Format(TimeValue(Format(Cells(x, 2).Value, "00:00")) + TimeValue(Format(Cells(topRow - 1, i).Value, "00:00")), "hhmm")
のあたりを直せばよさそうな感じがプンプンします。

回答No.5

n-jun

＃４です。

＞Set　rf　=　rr.Resize(,　20).Find(What:=T_r,　LookIn:=xlValues,　LookAt:=xlWhole)
Resizeの20は適当です。（20ならU列まで有効）

補足

ありがとうございます。データの数が膨大の所もあったので、一応多めに取っておきました。

回答No.3

n-jun

＃２です。

＞しかし、難しそうなので、他の方法でこれを実装するやり方を考えなければならないのでしょうか？
元々が”課題”として出されているならば、やり方を変更する事は出来ないでしょう。

ただ”ある目的のための手段のひとつ”であるならば、その”目的”がわかれば
やり方の再検討について回答がつくかも知れません。

私ならまずは”時間”で求めるのではなく、”数値（単純に足し算の答え）”で
同様の事が出来るか挑戦し、できたら時間に置き換えてやってみるかな。

補足

ありがとうございます。そうですか…
この方法でやれということではなく、こういう結果（画像のように）になるようにしなさい。

ということなので何か別案で考えていくしかないみたいですね。

回答No.2

n-jun

＞Ｃ列以降は時刻です（：は抜いて対応）
ってセルの値は数字なのかシリアル値なのかって疑問です。

私もどこかで見たような質問と感じてましたが、＃１さん回答の質問だったのですね。
その質問の補足にある
＞データによっては3行目、4行目からと変則的にB列に所要時間を入れていきたいのですが
が今回の
＞Ｂ列の数字は０と入力した駅からそれぞれの駅までの
と言う事みたいですね。

Ｂ列に不要なデータがあるかどうか（平均的な所要時間以外のデータの存在）で
回答に変化がありそうですけど。
⇒そのデータ数が”比較の為のループ回数を決める”と感じますが、
　コード化出来ないので的はずれかも知れません。

補足

回答ありがとうございます。

＞Ｃ列以降は時刻です（：は抜いて対応）
ってセルの値は数字なのかシリアル値なのかって疑問です。
についてですが、セルの値は数字になります。

＞Ｂ列に不要なデータがあるかどうか（平均的な所要時間以外のデータの存在）で
についてですが、平均的な所要時間以外のデータは存在しません。
ループの回数は０の数字の右隣の時刻データから最後の所までなので
例で言うと、B3から０が始まっている場合ループ回数は４回
　　　　　　　　B4から０が始まっている場合ループ回数は６回
という風になります。

しかし、難しそうなので、他の方法でこれを実装するやり方を考えなければならないのでしょうか？

回答No.1

うぃず（@Wizard_Zero）

http://okwave.jp/qa5248522.html
ここにほとんど同じようなことをしている回答とコードが出ています。参考にされてみてはいかがでしょう？

ところで・・・
投稿者名が変わっていますが上記「qa5248522」の質問者と同じ方でしょうか？　質問の内容・文面等が非常に似ているので…。もしそうなら前回、回答で提示されたコードの改造を試みていたりしていないのか、なぜ投稿名を変えたのか等が気になります。違っていたらすみません。

補足

すでに既出だったんですね。ありがとうございます。
実行結果は残念ながら期待通りの動きはしてくれませんでした。

質問主さんの言う通りで1つでも一致していたら色が付いてしまいます。改造しろと言われても初心者のため、どこをどう弄ったらいいかもわかりません。