• 締切済み

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

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

みんなの回答

  • imogasi
  • ベストアンサー率27% (4737/17069)
回答No.2

マッチング法 (1)Sheet1に1分刻みの時刻を作る(下記では600分、変えれば増やせる) (2)Sheet2から、Sheet1へ、もし同じ時刻があれば、Sheet2のB列の データを、Sheet1のB列に持ってゆく。 同じ時刻がSheet2に無ければ、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列に1分刻みの表作成 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列は、エクセルの正式の時刻入力(時刻シリアル値)であることは、絶対条件です。

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.1

こんにちは。 以下は、同じ日付の判定のみです。それ以外はできませんので、もし違うようでしたら、範囲の部分を手書きで書き換えてください。 そのデータの使い方にもよりますが、たとえば、フィルハンドルでコピーしたものを、並べ替えなどでしても、データは、浮動小数点誤差が発生しているので、見かけの表示と内容が食い違ってしまっていることがあります。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

mm679433
質問者

お礼

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

関連するQ&A