歯抜けの時間を埋めて行の挿入

過去に同じような質問があり試しましたが、うまく出来ませんでしたので、教えて頂けないでしょうか。（エクセル２００３を使用）
日付　時間　数値　　　　　　
10/9　9：00　３
10/9　9：01　２
10/9　9：03　５
10/9　9：05　２
上記の図のように、時間（分）が入力されているデータを、下記の図のように歯抜けデータを埋めて挿入するには、どうしたらよろしいでしょうか？
日付　時間　数値
10/9　9：00　３
10/9　9：01　２
10/9　9：02　　←挿入したいデータ
10/9　9：03　５
10/9　9：04　　←挿入したいデータ
10/9　9：05　２

No.2 回答者： imogasi 回答日時： 2007/10/15 20:02

マッチング法

（１）Sheet1に１分刻みの時刻を作る（下記では６００分、変えれば増やせる）
（２）Sheet2から、Sheet1へ、もし同じ時刻があれば、Sheet2のB列の
データを、Sheet1のB列に持ってゆく。
同じ時刻がSheet２に無ければ、Sheet1のB列のその行を飛ばしている。
ーーー
Sub test01()
lst = 600 '600分間
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
'--Sheet1のA列に１分刻みの表作成
For i = 1 To lst
sh1.Cells(i, 1) = TimeSerial(9, i, 0)
Next i
'-----両シートをマッチング
k = 1
i = 1
cmp:
If i > lst Or Cells(k, "A") = "" Then GoTo endr
If sh1.Cells(i, "a") = sh2.Cells(k, "a") Then GoTo eql
If sh1.Cells(i, "a") > sh2.Cells(k, "a") Then GoTo high
If sh1.Cells(i, "a") < sh2.Cells(k, "a") Then GoTo low
GoTo cmp:
'--
eql:
sh1.Cells(i, "B") = sh2.Cells(k, "B")
i = i + 1
k = k + 1
GoTo cmp
high:
GoTo endr
low:
i = i + 1
GoTo cmp
'--終わり
endr:
End Sub
Sheet2のほうで、少数のデータでしかテストできてないので、よろしく。
上記がうまくうごくのは、Sheet1のA列は、エクセルの正式の時刻入力（時刻シリアル値）であることは、絶対条件です。

No.1 回答者： Wendy02 回答日時： 2007/10/11 13:34

こんにちは。

以下は、同じ日付の判定のみです。それ以外はできませんので、もし違うようでしたら、範囲の部分を手書きで書き換えてください。

そのデータの使い方にもよりますが、たとえば、フィルハンドルでコピーしたものを、並べ替えなどでしても、データは、浮動小数点誤差が発生しているので、見かけの表示と内容が食い違ってしまっていることがあります。Text関数などで作る方法もあるかと思いますが、今回は、マクロを使いました。


'標準モジュール

Sub TestEnterRows()
　　Dim r As Range
　　Dim i As Long
　　Dim m As Long
　　Dim n As Long
　　
　　'範囲
　　Set r = Range("B2", Range("B65536").End(xlUp))
　　
　　For i = r.Count To 2 Step -1
　　　　'整数比較
　　　　n = TimeValue(r.Cells(i, 1).Text) * 24 * 60
　　　　m = TimeValue(r.Cells(i - 1, 1).Text) * 24 * 60 + 1
　　　　If m <> n Then
　　　　　　r.Cells(i, 1).EntireRow.Insert
　　　　　　r.Cells(i, 1).Value = (TimeValue(r.Cells(i + 1, 1).Text) * 24 * 60 - 1) / _
　　　　　　(24 * 60)
　　　　　　r.Cells(i, 1).Offset(, -1).Value = r.Cells(i + 1, 1).Offset(, -1).Value
　　　　　　a = r.Cells(i, 1).Address
　　　　　　i = i + 1
　　　　End If
　　Next i
　　Set r = Nothing

End Sub

この回答へのお礼

過去のデータがたくさんで困っていました。
作業のスピードが速くなります。ありがとうございました。

お礼日時：2007/10/11 14:21