電車の時刻表がありまして
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から入れるわけではなく、ケースバイケースで変わってきます。
一応、この例をマクロを使って無事動いた時の画像も載せておきます
といったマクロを作りたいのですが、初心者のため手も足も出ません。
時間もないので、マクロ作成に自信のお有りの方、もしよろしければこれを実装するためのコードを教えて頂けないでしょうか?
丸投げで誠に申し訳ございません。
長文失礼足しました。
No.4ベストアンサー
- 回答日時:
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」に書き換えたもう一つのマクロ作る事により解決できました。
本当にこんな駄目な自分のためにお付き合いしていただきありがとうございました。
No.8
- 回答日時:
>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です。
>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で指摘させて頂いたエラーは無くなりました。
もう一つマクロを作成しなくなった分だけスリムになって良かったです。
この度は誠にありがとうございました。
No.6
- 回答日時:
いや~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.3
- 回答日時:
#2です。
>しかし、難しそうなので、他の方法でこれを実装するやり方を考えなければならないのでしょうか?
元々が”課題”として出されているならば、やり方を変更する事は出来ないでしょう。
ただ”ある目的のための手段のひとつ”であるならば、その”目的”がわかれば
やり方の再検討について回答がつくかも知れません。
私ならまずは”時間”で求めるのではなく、”数値(単純に足し算の答え)”で
同様の事が出来るか挑戦し、できたら時間に置き換えてやってみるかな。
この回答への補足
ありがとうございます。そうですか…
この方法でやれということではなく、こういう結果(画像のように)になるようにしなさい。
ということなので何か別案で考えていくしかないみたいですね。
No.2
- 回答日時:
>C列以降は時刻です(:は抜いて対応)
ってセルの値は数字なのかシリアル値なのかって疑問です。
私もどこかで見たような質問と感じてましたが、#1さん回答の質問だったのですね。
その質問の補足にある
>データによっては3行目、4行目からと変則的にB列に所要時間を入れていきたいのですが
が今回の
>B列の数字は0と入力した駅からそれぞれの駅までの
と言う事みたいですね。
B列に不要なデータがあるかどうか(平均的な所要時間以外のデータの存在)で
回答に変化がありそうですけど。
⇒そのデータ数が”比較の為のループ回数を決める”と感じますが、
コード化出来ないので的はずれかも知れません。
この回答への補足
回答ありがとうございます。
>C列以降は時刻です(:は抜いて対応)
ってセルの値は数字なのかシリアル値なのかって疑問です。
についてですが、セルの値は数字になります。
>B列に不要なデータがあるかどうか(平均的な所要時間以外のデータの存在)で
についてですが、平均的な所要時間以外のデータは存在しません。
ループの回数は0の数字の右隣の時刻データから最後の所までなので
例で言うと、B3から0が始まっている場合ループ回数は4回
B4から0が始まっている場合ループ回数は6回
という風になります。
しかし、難しそうなので、他の方法でこれを実装するやり方を考えなければならないのでしょうか?
No.1
- 回答日時:
ここにほとんど同じようなことをしている回答とコードが出ています。参考にされてみてはいかがでしょう?
ところで・・・
投稿者名が変わっていますが上記「qa5248522」の質問者と同じ方でしょうか? 質問の内容・文面等が非常に似ているので…。もしそうなら前回、回答で提示されたコードの改造を試みていたりしていないのか、なぜ投稿名を変えたのか等が気になります。違っていたらすみません。
この回答への補足
すでに既出だったんですね。ありがとうございます。
実行結果は残念ながら期待通りの動きはしてくれませんでした。
質問主さんの言う通りで1つでも一致していたら色が付いてしまいます。改造しろと言われても初心者のため、どこをどう弄ったらいいかもわかりません。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Excel(エクセル) Excel2007での条件付き書式について 6 2023/05/02 10:56
- Excel(エクセル) 表内で、Enterキーで横→行の最後入力したら次の行の先頭に移動するマクロを作りたい 3 2022/05/01 21:19
- Visual Basic(VBA) Excel vbaについて知恵もしくは、コード教えて下さいm(__)m ① 表にあるデータをコピー、 2 2022/09/01 23:57
- Visual Basic(VBA) 複数csvを横に追加していくマクロについて 2 2023/04/25 09:19
- Excel(エクセル) [オートフィルター]機能について 3 2023/02/04 14:32
- Excel(エクセル) エクセルの条件付き書式 個人シートを参照して集計シートに色付けしたい 1 2023/06/22 00:39
- Excel(エクセル) エクセルVBAで次の二つを行いたいのですが思うように動きません。どう修正したらよいのでしょうか? 2 2023/04/22 14:55
- Excel(エクセル) セルに特定の色が出た時だけ、式を発動させたい 4 2022/06/17 10:32
- Excel(エクセル) エクセルのマクロでコピー後の貼り付け先を毎回指定したところにしたい 5 2022/08/12 10:47
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VBA UserFormからの転記で
-
Cellsのかっこの中はどっちが行...
-
Worksheets メソッドは失敗しま...
-
IIF関数の使い方
-
Excel VBA 検索した値を入力フ...
-
【VBA】2つのシートの値を比較...
-
Excelで、あるセルの値に応じて...
-
vba 2つの条件が一致したら...
-
Changeイベントでの複数セルの...
-
VBAで、特定の文字より後を削除...
-
複数csvを横に追加していくマク...
-
VBA 何かしら文字が入っていたら
-
targetをA列のセルに限定するに...
-
VBAを使って検索したセルをコピ...
-
エクセルVBA シートモジュール...
-
VBAでセルアドレスに変数を使い...
-
VBAでオートフィルタの抽出結果...
-
期限を超えた日付に警告のメッ...
-
Pythonについて。
-
VBAのコードを教えてください
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Worksheets メソッドは失敗しま...
-
Cellsのかっこの中はどっちが行...
-
Excelで、あるセルの値に応じて...
-
vba 2つの条件が一致したら...
-
B列の最終行までA列をオート...
-
VBAを使って検索したセルをコピ...
-
エクセルVBAでデータ転記
-
IIF関数の使い方
-
マクロ 最終列をコピーして最終...
-
文字列の結合を空白行まで実行
-
VBA 何かしら文字が入っていたら
-
Changeイベントでの複数セルの...
-
VBAのFind関数で結合セルを検索...
-
【VBA】2つのシートの値を比較...
-
VBマクロ 色の付いたセルを...
-
VBAでのリスト不一致抽出について
-
【VBA】複数行あるカンマ区切り...
-
VBA 値と一致した行の一部の列...
-
データグリッドビューの一番最...
-
エクセルVBA シートモジュール...
おすすめ情報