マクロ作成について

質問

今、時刻表と合致するセルに色を付けてソートするマクロを作っています。
次のようになっています。（停留所が3つの場合）

　　Ａ　　Ｂ　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　Ｉ　　　Ｊ　　　Ｋ　　　Ｌ　
１
２　a　　0　　1059　1145　1858
３　b　　1　　1030　1100　1130　1146　1510　1859
４　c　　2　　1000　1031　1101　1131　1147　1412　1511　1900
５　

Ａ列のa、b、cはそれぞれバス停名です。C2～J4に書いてある数字はそれぞれのバス停の発車時刻になります。
また、B列の数字はバス停名aを起点としてb、cのバス停までの所要時間です。B列に関してはユーザーの方で入力。以上を踏まえまして、今回実装したいことは、

(1)C2から範囲選択をして色を付け、選択した範囲とB列に入力した数字を足して、それと合致したセルに色を付ける。
　　Ａ　　Ｂ　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　Ｉ　　　Ｊ　　　Ｋ　　　Ｌ　
１
２　a　　0　　1059　1145　1858
３　b　　1　　1030　1100　1130　1146　1510　1859
４　c　　2　　1000　1031　1101　1131　1147　1412　1511　1900
５
これを行うとセルC2～E2とD3、F3、H3、E4、G4、J4には色が付くことになります。

(2)(1)で色の付いたセルのみをソート（色の付いていない部分は後ろのセルへ移動）
　　Ａ　　Ｂ　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ　　　Ｈ　　　Ｉ　　　Ｊ　　　Ｋ　　　Ｌ　
１
２　a　　0　　1059　1145　1858
３　b　　1　　1100　1146　1859　1030　1130　1859
４　c　　2　　1101　1147　1900　1000　1031　1131　1412　1511
５　

以上になります。これを実装するためのコードを教えては頂けないでしょうか？よろしくお願いいたします。

回答No.2

nag0720

＞もし足した数とマッチするセルがなければ、範囲を選択した時に対応するセルは色を付けないようにする

Sub Test()
Dim n As Integer
Dim w As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim c As Range
Dim h As Integer
Dim m As Integer
Dim p As Integer

n = Cells(Rows.Count, 1).End(xlUp).Row ' 停留所の最終行

' 選択した範囲とB列に入力した数字を足して、それと合致したセルに色を付ける
For i = 3 To n
For Each c In Selection
h = Int(c.Value / 100)
m = c.Value Mod 100 + Range("B" & i).Value
Do While m >= 60
h = h + 1
m = m - 60
Loop
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(i, j).Value = h * 100 + m Then
With c.Interior
.ColorIndex = 6
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(i, j).Interior
.ColorIndex = 6
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Exit For
End If
Next
Next
Next

' 色の付いたセルのみをソート（色の付いていない部分は後ろのセルへ移動）
w = n + 1 ' 作業用の行
For i = 3 To n ' ２行目もソートする場合は、3→2
Rows(i & ":" & i).Copy
ActiveSheet.Paste Destination:=Rows(w & ":" & w)
p = 3
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(w, j).Interior.ColorIndex = 6 Then
k = p
Do While k > 3
If Cells(i, k - 1).Value <= Cells(w, j).Value Then Exit Do
Cells(i, k - 1).Copy
ActiveSheet.Paste Destination:=Cells(i, k)
k = k - 1
Loop
Cells(w, j).Copy
ActiveSheet.Paste Destination:=Cells(i, k)
p = p + 1
End If
Next
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(w, j).Interior.ColorIndex <> 6 Then
Cells(w, j).Copy
ActiveSheet.Paste Destination:=Cells(i, p)
p = p + 1
End If
Next
Next
Application.CutCopyMode = False
Rows(w & ":" & w).Delete ' 作業用の行の削除
End Sub

ただし、３行目以降のすべての行でマッチしないときのみ色が付きません。１つでもマッチする行があれば色が付きます。
２行目はソートしていません。
２行目もソートしたい場合は、プログラムの真ん中ぐらいにある「For i = 3 To n」を「For i = 2 To n」に変えてください。

補足

度々ありがとうございます。
動作を確認しました。nag0720さんのおっしゃる通り、3行目のすべての行でマッチしないときは色は付きませんでした。
しかし、頂いたデータの中には1つでもマッチすることが多いので、1つでもマッチしない行があっても色が付かない方が良いのですが…

あと、今回は2行目からB列に０、１、２…と入れていきましたが、
データによっては3行目、4行目からと変則的にB列に所要時間を入れていきたいのですが、このコードだと2行目から所要時間を入れないと、動いてくれません。3行目、4行目からに対応するにはfor文のi、jの始まりの数字を変えれば対応するのですが、これでは毎回数字を変えなくてはならないので面倒です。何行目から所要時間を入れても対応できるようにするにはどのようにすればよいでしょうか？

後でいろいろと補足してしまって申し訳ございません。

回答No.1

nag0720

一応作成してみました。
アルゴリズムを組み立てるのは得意なのですが、ExcelのVBAは専門ではないので、もっと簡単なコマンドがあるかもしれません。

２行目のセルを範囲選択してから実行してください。

Sub Test()
Dim n As Integer
Dim w As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim c As Range
Dim h As Integer
Dim m As Integer
Dim p As Integer

' 選択セルに色を付ける
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

n = Cells(Rows.Count, 1).End(xlUp).Row ' 停留所の最終行

' 選択した範囲とB列に入力した数字を足して、それと合致したセルに色を付ける
For i = 3 To n
For Each c In Selection
h = Int(c.Value / 100)
m = c.Value - h * 100 + Range("B" & i).Value
Do While m >= 60
h = h + 1
m = m - 60
Loop
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(i, j).Value = h * 100 + m Then
With Cells(i, j).Interior
.ColorIndex = 6
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
Next
Next
Next

' 色の付いたセルのみをソート（色の付いていない部分は後ろのセルへ移動）
w = n + 1 ' 作業用の行
For i = 3 To n
Rows(i & ":" & i).Copy
ActiveSheet.Paste Destination:=Rows(w & ":" & w)
p = 3
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(w, j).Interior.Color = 65535 Then
k = p
Do While k > 3
If Cells(i, k - 1).Value <= Cells(w, j).Value Then Exit Do
Cells(i, k - 1).Copy
ActiveSheet.Paste Destination:=Cells(i, k)
k = k - 1
Loop
Cells(w, j).Copy
ActiveSheet.Paste Destination:=Cells(i, k)
p = p + 1
End If
Next
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(w, j).Interior.Color <> 65535 Then
Cells(w, j).Copy
ActiveSheet.Paste Destination:=Cells(i, p)
p = p + 1
End If
Next
Next
Application.CutCopyMode = False
Rows(w & ":" & w).Delete ' 作業用の行の削除
End Sub

お礼

回答に補足するのは失礼かと思いますが補足の補足で例えばＣ３が1101になっていたとしたらＣ２に対応するのがなくなるので、Ｃ２には色を付けないという感じです。

補足

動作確認致しました。質問通りの動作をしてくれました。ありがとうございます。もう一つ、追加で質問なんですが、範囲を選択してＢ列の足し算をするわけですが、もし足した数とマッチするセルがなければ、範囲を選択した時に対応するセルは色を付けないようにする事は可能でしょうか？