Excelのマクロについて質問です。 以下のようなデータに対し、条件に合うデータのみを抽出したいです

Excelのマクロについて質問です。
以下のようなデータに対し、条件に合うデータのみを抽出したいです。
(条件)
・長さ→15.0以上
・重量→10.00以下
・速度→３つ上のデータと比較し差が±0.05なら抽出(3個目のデータは一番最後のデータと比較、2個目のデータは最後から一つ前のデータと比較、1個目のデータら最後から二つ前のデータと比較)

| A | B | C | D |
1|時間 |長さ| 重量| 速度 |
2|8:00|15.5|5.25|15.25|
3|9:00|20.3|7.55|12.27|
4|9:30|10.7|3.85|17.85|
・
・
・

どなたかわかる方教えて頂きたいです。
コードを乗せて頂けると助かります。

No.6 ベストアンサー 回答者： WindFaller 回答日時： 2016/09/19 18:50

こんばんは。

この問題というのは、VBAの基礎を試すのに良い問題ですね。（^^;
アップロード寸前で気が付きました。
小数点のある計算は、全部狂いが生じます。

マクロのコードの内容は別にして、どの計算も全部、浮動小数点誤差が発生します。以前も、こんな回答をしたことがあるけれども、質問者さんは理解しなかったです。ところが、これが、ワークシート上でも狂っているのですから、目も当てられないっていう感じです。

Excel で浮動小数点演算の結果が正しくない場合がある
https://support.microsoft.com/ja-jp/kb/78113
（だいたい、6～7割は間違っています。）10進にすればこんなことはありません。今回は、@ -Currency 型で計算させています。

'//
Sub TestDataAnlysing()
　Dim LastRow As Long
　Dim i As Long, j As Long
　Dim rng As Range
　Dim sh2 As Worksheet: Set sh2 = Worksheets("Sheet2")
　If Range("A1").CurrentRegion.Rows.Count < 4 Then
　　MsgBox "この表では集計ができません。", vbExclamation
　　Exit Sub
　End If
　Set rng = ActiveSheet.Range("A2", Cells(Rows.Count, 1).End(xlUp))
　LastRow = rng.Rows.Count
　sh2.Cells(1, 1).Resize(, 4).Value = Array("時間", "長さ", "重量", "速度")
　j = 2 '初期値
　
　With rng
　For i = 1 To LastRow
　　If .Cells(i, 2).Value >= 15@ And _
　　　.Cells(i, 3).Value <= 10@ Then
　　　If i < 4 Then

　　　　If Abs(.Cells(i, 4).Value - .Cells(LastRow - 3 + i, 4).Value) <= 0.05@ Then
　　　　　.Cells(i, 1).Resize(, 4).Copy sh2.Cells(j, 1)
　　　　　j = j + 1
　　　　End If
　　　Else
　　　　If Abs(.Cells(i - 3, 4).Value - .Cells(i, 4).Value) <= 0.05@ Then
　　　　.Cells(i, 1).Resize(, 4).Copy sh2.Cells(j, 1)
　　　　j = j + 1
　　　　End If
　　　End If
　 End If
Next i
End With
End Sub

No.5 回答者： tatsu99 回答日時： 2016/09/19 18:15

GooUserラックとママチャリさんの回答を拝見しました。

基本的にはGooUserラックので問題ないと思いますが、1点以下の不具合が見受けられます。
コピー先がsheet2ですが、実行後、sheet2の内容の時間の欄が時刻の表示でなく、数値の表示になってしまいます。
（例：8:00の場合、sheet2では0.333333333と表示）
これは、セルの書式を含めてコピーせず、値のみコピーしているのが原因かと思われます。

ママチャリさんの回答は、データが5件以上ある場合は動作しませんでした。
また、データが4件以内であれば、動作しますが、速度の差が丁度0.05の場合、それを抽出してくれません。
（例　速度が15.25と15.30の場合は、差が0.05なので、抽出すべきだが抽出されない）

上記の不具合を改修したソースを以下に提示しますので、実行してみてください。
尚、コピー元はsheet1、コピー先はsheet2に限定していますので、必要があればあなたの環境にあわせて修正してください。
又、データ件数は、最低４件以上とします。3件の場合は、速度の比較先が自分自身になるので（同じ行の速度を比較する）、意味がないと判断しました。
----------------------------------------------------
Option Explicit

Public Sub Macro1()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim maxrow As Long 'sheet1の最大行数
Dim row As Long '処理中の行
Dim row2 As Long '速度比較先の行
Dim row3 As Long 'Sheet2へコピーする行
Dim count As Long 'コピーした件数
Const diffBand As Double = 0.05
Dim diff As Variant
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")
'最終行を取得
maxrow = sh1.Cells((Rows.count), 1).End(xlUp).row
If maxrow < 5 Then
MsgBox ("行数不足")
Exit Sub
End If
'見出しをコピー
sh1.Rows(1).Copy
sh2.Rows(1).PasteSpecial
count = 0
For row = 2 To maxrow
'比較先の行を求める
row2 = row - 3
If row2 < 2 Then
row2 = row2 + maxrow - 1
End If
'MsgBox ("row=" & row & " row2=" & row2)
With sh1
'抽出条件をチェック
diff = Abs(CDec(.Cells(row2, 4)) - CDec(.Cells(row, 4)))
If .Cells(row, 2).Value >= 15# And .Cells(row, 3) <= 10# And diff <= diffBand Then
'条件成立ならsheet2へコピー
count = count + 1
row3 = count + 1
sh1.Rows(row).Copy
sh2.Rows(row3).PasteSpecial
End If
End With
Next
Application.CutCopyMode = False
MsgBox (count & "件コピーしました")
End Sub
------------------------------------------------------

No.4 回答者： ママチャリ 回答日時： 2016/09/19 08:55

こんな感じでしょうか。

（データは4個以上必要です）

Sub Sample()
Dim LastRow As Long
Dim oWs As Worksheet
Dim i As Long
Dim j As Long
Dim o As Long
o = 2
Set oWs = Sheets.Add(After:=Sheets(Sheets.Count))
With Sheets("Sheet1")
.Rows("1").Copy Destination:=oWs.Rows("1")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
j = Choose(i, 0, LastRow - 2, LastRow - 1, LastRow, i - 3)
If .Cells(i, "B").Value >= 15 And _
.Cells(i, "C").Value <= 10 And _
Abs(.Cells(i, "D").Value - .Cells(j, "D").Value) <= 0.05 Then
.Rows(i).Copy Destination:=oWs.Rows(o)
o = o + 1
End If
Next i
End With
End Sub

No.3 回答者： GooUserラック 回答日時： 2016/09/19 00:26

あまりテストしていませんがこんな感じでしょうか？

-----------------------------------------------------------------------
Sub Sample()
Dim 行 As Long
Dim 終 As Long
Dim 先 As Long
Dim 列 As Long
Const シート名 As String = "Sheet2"
Sheets(シート名).Cells.ClearContents
Sheets(シート名).Range("A1").Value = "時間"
Sheets(シート名).Range("B1").Value = "長さ"
Sheets(シート名).Range("C1").Value = "重量"
Sheets(シート名).Range("D1").Value = "速度"
終 = Cells(Rows.Count, 1).End(xlUp).Row - 4
先 = 2
For 行 = 2 To 4
If Cells(行, 2).Value >= 15 Then
If Cells(行, 3).Value <= 10 Then
If Cells(行, 4).Value <= Cells(終 + 行, 4).Value + 0.05 Then
If Cells(行, 4).Value >= Cells(終 + 行, 4).Value - 0.05 Then
For 列 = 1 To 4
Sheets(シート名).Cells(先, 列).Value = Cells(行, 列).Value
Next
先 = 先 + 1
End If
End If
End If
End If
Next
終 = Cells(Rows.Count, 1).End(xlUp).Row
For 行 = 5 To 終
If Cells(行, 2).Value >= 15 Then
If Cells(行, 3).Value <= 10 Then
If Cells(行, 4).Value <= Cells(行 - 3, 4).Value + 0.05 Then
If Cells(行, 4).Value >= Cells(行 - 3, 4).Value - 0.05 Then
For 列 = 1 To 4
Sheets(シート名).Cells(先, 列).Value = Cells(行, 列).Value
Next
先 = 先 + 1
End If
End If
End If
End If
Next
End Sub
-----------------------------------------------------------------------
※ データが３行以上必要です。
※ 貼付先シート名は「Const シート名 As String = "Sheet2"」を変更して下さい。

No.2 回答者： GooUserラック 回答日時： 2016/09/18 23:35

念の為確認です。

「・速度→３つ上のデータと比較し差が±0.05なら抽出」は「・速度→３つ上のデータと比較し差が±0.05以内なら抽出」でしょうか？

この回答へのお礼

そうです。
コード試してみます！
ありがとうございます！

お礼日時：2016/09/19 01:05

No.1 回答者： GooUserラック 回答日時： 2016/09/18 20:57

「抽出」とはどうするのですか？

たとえば、条件に合わない行を非表示にする？

この回答へのお礼

すみません。
情報が抜けてました。
基データから条件に合うデータを新しいシートに抽出するようなイメージです。

お礼日時：2016/09/18 22:46