『データを比べて行挿入』（shinv230） 以下のようなデータから時間データが欠落した場合に欠落分の行を挿入したいと思います。 　 A　　 B C D 　 E F G　　・　 AS 1　 日時 記録-1 記録-2 記録-3 記録-4 記録-5　・ 記録-44 2 2010/12/29 0:00 1.22 2.11 1.35 2.63 1.21　　・ 3.55 3 2010/12/29 0:01 1.21 2.10 1.37 2.59 1.09　　・ 3.49 4 2010/12/29 0:02 1.23 2.13 1.39 2.60 1.19　　・ 3.51 5 2010/12/29 0:04 1.19 2.15 1.33 2.55 1.23　　・ 3.48 6 2010/12/29 0:05 1.24 2.09 1.32 2.61 1.18　　・ 3.52 7 2010/12/29 0:09　1.18 2.14 1.29 2.54 1.24　　・ 3.54 B1とC1(C1とD1)の場合は，差が1分なのでそのままとし，D1とE1の差が2分なのでD1の下に 1行挿入し，F1とG1の差が4分なので3行挿入するようなことはできますか? 現在は，VLOOKUPを使用して各時間毎に記録をそれぞれ転記していますがデータ量が多いた め時間を費やしています。(記録-1から記録-44の7日分を1分毎に転記しています) よろしくお願いします。 Excel2003 ---- 私の読解力が足りないのか、表と表の下の文章が結びつきません。 もしかして >B1とC1(C1とD1)の場合は，差が1分なのでそのままとし，D1とE1の差が2分なのでD1の下に >1行挿入し，F1とG1の差が4分なので3行挿入するようなことはできますか? は A2とA3(A3とA4)の場合は，差が1分なのでそのままとし，A4とA5の差が2分なのでA4の下に 1行挿入し，A6とA7の差が4分なので3行挿入するようなことはできますか? ということでしょうか。 また、7日分ということは、最終結果が10080 行（60*24*7）になるということでしょうか。 であればマクロになりますが、 Sub InsRows() Dim lastRow As Long lastRow = Range("A" & Rows.Count).End(xlUp).Row Dim crMin As Long Dim prMin As Long Dim r As Long prMin = Int(CDate(Cells(lastRow, "A").Value) * 24 * 60 + 0.1) For r = lastRow To 3 Step -1 crMin = prMin prMin = Int(CDate(Cells(r - 1, "A").Value) * 24 * 60 + 0.1) If (crMin - prMin) > 1 Then Cells(r, "A").Resize(crMin - prMin - 1).EntireRow.Insert End If Next End Sub でどうでしょうか。 (Mook) ---- Mookさんご指導有難うございます。 私の説明文と表が一致していませんでした。正しくはご指摘のとおり >A2とA3(A3とA4)の場合は，差が1分なのでそのままとし，A4とA5の差が2分なのでA4の下に >1行挿入し，A6とA7の差が4分なので3行挿入するようなことはできますか?　になります。 Mookさんのマクロで希望通りに行を挿入することができました。 あつかましいお願いですが挿入した行に欠落分の日時を表示することは可能でしょうか? 他のデータとの相関グラフを作成するときに欠落した日時を入力することを避けたいと思い ます。よろしくお願いします。(shinv230) ---- こんなのでは？ Option Explicit Public Sub Sample_1() 'Listのデータ列数（A列〜AS列） Const clngColumns As Long = 45 'Listの中のKeyと成る列位置(基準列からの列Offset：3列目) Const clngKey As Long = 0 Dim i As Long Dim lngRows As Long Dim rngList As Range Dim vntData As Variant Dim lngAppend As Long Dim lngFirstDay As Long Dim lngCompare As Long Dim strProm As String 'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置） Set rngList = ActiveSheet.Range("A1") With rngList '行数の取得 lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row If lngRows <= 0 Then strProm = "データが有りません" GoTo Wayout End If '列データを配列に取得 vntData = .Offset(1, clngKey).Resize(lngRows + 1).Value2 End With '追加行位置を最終行位置に lngAppend = lngRows '画面更新を停止 Application.ScreenUpdating = False '先頭日付を取得 lngFirstDay = Int(vntData(1, 1)) '先頭時刻を比較時刻として取得 lngCompare = ConvMinute(vntData(1, 1), lngFirstDay) '時刻列に就いて繰り返し i = 1 Do Until i > lngRows '現在時刻と比較時刻が違ったら If lngCompare <> ConvMinute(vntData(i, 1), lngFirstDay) Then '最終行の下に不足分の時刻を記述 lngAppend = lngAppend + 1 With rngList '日付を転記 .Offset(lngAppend, clngKey).Value = ConvTime(lngCompare, lngFirstDay) 'データを転記 ' .Offset(lngAppend, clngKey + 1).Resize(, clngColumns - 1).Value _ = .Offset(i - 1, clngKey + 1).Resize(, clngColumns - 1).Value End With Else i = i + 1 End If '比較時刻を更新 lngCompare = lngCompare + 1 Loop With rngList '追加行が有るなら If lngRows < lngAppend Then 'A列をKeyとして整列 .Offset(1).Resize(lngAppend, clngColumns).Sort _ Key1:=.Offset(1), Order1:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlStroke strProm = (lngAppend - lngRows) & "件の追加処理が完了しました" Else strProm = "追加行は有りません" End If End With Wayout: '画面更新を再開 Application.ScreenUpdating = True Set rngList = Nothing MsgBox strProm, vbInformation End Sub Private Function ConvMinute(vntValue As Variant, lngFirst As Long) As Long 'シリアル値を午前0時からの経過分に変換 Dim lngDay As Long lngDay = Int(vntValue - lngFirst) * 24 * 60 ConvMinute = lngDay + Hour(vntValue) * 60 + Minute(vntValue) End Function Private Function ConvTime(lngValue As Long, lngFirst As Long) As String '経過分を時刻に変換 Dim lngDate As Long Dim lngHour As Long Dim lngMinute As Long '比較時刻（経過分）を日付、時刻に変換 lngMinute = lngValue Mod 60 lngHour = (lngValue - lngMinute) Mod (24 * 60) lngDate = lngValue \ (24 * 60) ConvTime = Format(lngFirst + lngDate, "yyyy/m/d") & " " _ & Format(TimeSerial(lngHour, lngMinute, 0), "h:mm") End Function (Bun) ---- ゴメン、 時間の変換計算が間違えていました 以下のプロシージャを差し替えて下さい Private Function ConvTime(lngValue As Long, lngFirst As Long) As String '経過分を時刻に変換 Dim lngDate As Long Dim lngHour As Long Dim lngMinute As Long '比較時刻（経過分）を日付、時刻に変換 lngDate = lngValue \ (24 * 60) lngHour = (lngValue - lngDate * 24 * 60) \ 60 lngMinute = (lngValue - lngDate * 24 * 60) Mod 60 ConvTime = Format(lngFirst + lngDate, "yyyy/m/d") & " " _ & Format(TimeSerial(lngHour, lngMinute, 0), "h:mm") End Function (Bun) ---- Bunさん，ご指導有難うございます。 完璧です。いろいろ勉強になりました。 Bunさん，Mookさん これからも，ご指導いただくことがありましたらよろしくお願いします。 (shinv230) ---- 問題が発生しました。 Bunさんのマクロにて実際のデータにてマクロを実行したところ，正常に終了するデータと 途中でエラーになるデータが混在します。 「実行時エラー`1004`:アプリケーション定義またはオブジェクト定義エラーです」になり 以下の個所で中断します。 .Offset(lngAppend, clngKey).Value = ConvTime(lngCompare, lngFirstDay) 途中でエラーになるデータには時間データの欠落が比較的多いように思われます。 ご指導よろしくお願いします。 (shinv230) ---- 多分ですが、原因が解りました 時刻データに同一時刻、若しくは逆進のデータが有った場合 （例えば、「2011/1/6 0:08」の次が「2011/1/6 0:08」や「2011/1/6 0:07」の場合） Do〜Loopが無限Loopに成り、追加時刻をシートの最終行の下まで書き込もうとする為 エラーが起きると考えられます この場合のデータ修正をマクロでは出来ない（如何言う修正にするか決められない）ので データの確認用のマクロを組みました、データが上記の例の様な場合 そのデータのBackColorを変更して、MsgBoxで表示します 下記のコードを、前レスのコードと同じ標準モジュールに記述して下さい （ 前と同じ「Function ConvMinute」を使用していますので） Public Sub DataCheck() 'Listのデータ列数（A列〜AS列） Const clngColumns As Long = 45 'Listの中のKeyと成る列位置(基準列からの列Offset：0列目) Const clngKey As Long = 0 Dim i As Long Dim lngRows As Long Dim rngList As Range Dim vntData As Variant Dim lngFirstDay As Long Dim lngCompare As Long Dim blnFlag As Boolean Dim strProm As String 'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置） Set rngList = ActiveSheet.Range("A1") With rngList '行数の取得 lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row If lngRows <= 0 Then strProm = "データが有りません" GoTo Wayout End If '列データを配列に取得 vntData = .Offset(1, clngKey).Resize(lngRows + 1).Value2 End With '画面更新を停止 Application.ScreenUpdating = False '先頭日付を取得 lngFirstDay = Int(vntData(1, 1)) '時刻列に就いて繰り返し For i = 2 To lngRows '時刻が同じか-で在るかを確認 If ConvMinute(vntData(i - 1, 1), lngFirstDay) _ >= ConvMinute(vntData(i, 1), lngFirstDay) Then blnFlag = True rngList.Offset(i).Interior.ColorIndex = 8 End If Next i If blnFlag Then strProm = "同一時刻若しくは、逆進のデータが有ります" Else strProm = "データは正常です" End If Wayout: '画面更新を再開 Application.ScreenUpdating = True Set rngList = Nothing MsgBox strProm, vbInformation End Sub (Bun) ---- Bunさん解答有難うございます。 エラーの原因は,時刻データに同一時刻が存在し追加時刻をシートの最終行の下まで書き 込んでいました。 データの確認用のマクロにて問題は解消されました。 再度のフォロー有難うございました。 Bunさんこれからも，ご指導いただくことがありましたらよろしくお願いします。 (shinv230)