抜き出しマクロについて

質問

以下のプログラムは10行ごとにデータを抜き出すプログラムです。
これに追加して、普段は10行に1個データを抜き出し、前回の結果より10増減があったとき、
20結果の増減があった時にもデータを抜き出すようにするにはどうすればいいですか？

例えば以下の通り
time result
1　　　1
2　　　1
3　　　1
4　　　1
5　　　1
6　　　1
7　　　1
8　　　1
9　　　1
10　　 1
11　　100
12　　500
13　　1000
14　　1000
15　　1000
16　　1000
17　　1000
18　　1000
19　　1000
20　　1000
21　　1000
・　　・
・　　・
・　　・
　↓
time result
1　　　1
10　　1
11　　100
12　　500
13　　1000
20　　1000
・　　・
・　　・
・　　・

ここからプログラム
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
Sub nukitori()

Dim X As Worksheet
Dim i As Long
Dim ii As Long
Dim col As Integer
Dim Nukitori_Step As Long

Nukitori_Step = 10

i = 2
ii = 2 '●●●見出し行が１行目なので２で始める

Set X = ActiveSheet

'●シートShordataがあったら削除
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("shortdata").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add.Name = "shortdata"

'●先ず、見出しをコピー
Worksheets("shortdata").Rows(1).Value = X.Rows(1).Value

While X.Cells(i, 1) <> "" And i < 65535
For col = 1 To 255
Worksheets("shortdata").Cells(ii, col).Value = X.Cells(i, col).Value
Next
If i = 2 Then i = 1
i = i + Nukitori_Step
ii = ii + 1
Wend

End Sub

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.1

rivoisu · ベストアンサー

Sub 抽出()
Dim i As Long
Dim j As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Lastline As Long
Dim SelFlg As Boolean　　　　　　　　　'抽出データかどうかの
Set ws1 = Worksheets("OriginDT")　'元データ
Set ws2 = Worksheets("SelectDT")　'抽出データ
Lastline = ws1.Cells(Rows.Count, 1).End(xlUp).Row　'最終行番号を取得
ws2.Cells(1, 1) = ws1.Cells(1, 1)　　　　'見出し部分のコピー
ws2.Cells(1, 2) = ws1.Cells(1, 2)
j = 1
For i = 2 To Lastline
　　SelFlg = False
　　'10で割ったあまりが1（つまり10行おき)または最初のデータのとき
　　If i Mod 10 = 1 　or i=2 Then '
　　　　　　SelFlg = True　　　'抽出対象にする
　　End If
　　'2行目以降で一つ上の行との差が10以上のとき
　　If i > 3 And Abs(Cells(i, 1) -Cells(i - 1))　>=10 Then
　　　　　　SelFlg = True　　　'抽出対象にする
　　End If
　　If SelFlg = True Then　　'抽出対象だったらコピー
　　　　　　j = j + 1
　　　　　　ws2.Cells(j, 1) = ws1.Cells(i, 1)
　　　　　　ws2.Cells(j, 2) = ws1.Cells(i, 2)
　　End If
Next
End Sub
条件が増えたらif文を追加すればいい。(orになります。）