プロが教える店舗&オフィスのセキュリティ対策術

電車の時刻表がありまして
  A   B    C    D    E    F    G    H    I    J    K    L    M    N
1 
2 あ       1054  1425  1555  1725
3 い   0   1059  1430  1600  1730
4 う   5   1104  1235  1435  1505  1605  1735
5 え   7   1105  1237  1437  1507  1607  1737
6 お   9   1108  1239  1439  1509  1608  1739
7 か       1110  1240  1430  1440  1510  1610  1740  1840
8 き
9 く

A列は駅の名前、B列の数字は0と入力した駅からそれぞれの駅までの平均的な所要時間でC列以降は時刻です(:は抜いて対応)

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

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

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

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

(4)次はD3に移り、C列同様、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に色が付き、0と書かれた行の最終行なので処理が終了します。

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

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

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

長文失礼足しました。

「Excelのマクロ作成について」の質問画像

A 回答 (8件)

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ですが、期待通りの動きをしました。

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

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

補足日時:2009/09/06 18:46
    • good
    • 0

>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様誠にありがとうございました。

補足日時:2009/09/07 22:07
    • good
    • 0

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様、何度もありがとうございます。このコードで試した所、#4で指摘させて頂いたエラーは無くなりました。

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

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

補足日時:2009/09/06 21:47
    • good
    • 0

いや~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")
のあたりを直せばよさそうな感じがプンプンします。

補足日時:2009/09/06 21:43
    • good
    • 0

#4です。



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

この回答への補足

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

補足日時:2009/09/06 18:47
    • good
    • 0

#2です。



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

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


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

この回答への補足

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

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

補足日時:2009/09/06 17:30
    • good
    • 0

>C列以降は時刻です(:は抜いて対応)


ってセルの値は数字なのかシリアル値なのかって疑問です。

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

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

この回答への補足

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

>C列以降は時刻です(:は抜いて対応)
ってセルの値は数字なのかシリアル値なのかって疑問です。
についてですが、セルの値は数字になります。

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

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

補足日時:2009/09/06 13:21
    • good
    • 0

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

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

この回答への補足

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

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

補足日時:2009/09/06 11:40
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!