値を共有するペアを見つけ出し、削除したい。

質問

前提
C列にテキスト"on”が入る行xは必ずD列に整数の値αを持ちます。
αは行xだけでなく、行x以降にあり、かつC列に"off"が入る行のD列にも入ります。
x以降で一番xに近い"off”を含む行zにα以外の値が入る場合、入れ子となり、yはｚ以降の行に来ます。
ですので、xの直後に"off"を含む行が来ても、その行とxがペアとなるとは限りません。
※本文中にある代数は全て変数で、ペアごとに数値が変わるので固定の値ではありません。

やりたいこと
１、前提通りにαを共有する行をペアとする。
２、全てのペアを抽出する。
３、B列の値を使い、By-Bxの値をE列に返す。
４、By-Bx > 960の場合そのペアを含む行を全て削除したい。

３番までの工程は以下のようになります。
行16・21、行20・27、行25・26がペアです。
よろしくお願い致しますm(__)m
行 B 　 C　 D 　 E
16 0 　 on 60 480
中略
20 428 on 80 2000
21 480 off 60
中略
25 1464 on 60 1000
26 2464 off 60
27 2428 off 80

回答No.2

KURUMITO · ベストアンサー

関数を使って対応する方法です。
シート１にお示しのようなデータがA,B,C,D列の２行目から下方にあるとして、ご質問はE列のデータを表示させることとE列のデータが９６０よりも大きい数値の時にはそのペアを削除した表にしたいとのことですね。
削除した表についてはシート２に表示させることにして、シート１ではF列とG列には作業列を設けて対応します。
E２セルには次の式を入力します。

=IF(COUNTIF(G2,"on*")=0,"",IF(COUNTIF(G3:G$1000,SUBSTITUTE(G2,"on","off"))=0,"",INDEX(B3:B$1000,MATCH(SUBSTITUTE(G2,"on","off"),G3:G$1000,0))-B2))

F２セルには次の式を入力します。

=IF(AND(E2<>"",E2<=960),MAX(F$1:F1)+1,IF(COUNTIF(G:G,SUBSTITUTE(G2,"on","off"))=0,MAX(F$1:F1)+1,IF(AND(C2<>"",E2="",INDEX(E:E,MATCH(SUBSTITUTE(G2,"off","on"),G:G,0))<=960),MAX(F$1:F1)+1,"")))

G２セルには次の式を入力します。

=IF(C2="","",C2&D2&"/"&COUNTIF(G$1:G1,C2&D2&"*"))

E２セルからG２セルを選択してからそれらの式を下方にドラッグコピーします。
なお、F,G列が目障りでしたらそれらの列を選択してから右クリックして「非表示」を選択すればよいでしょう。

以上でシート１での作業は終わってシート２に移ります。
シート２のA２セルには次の式を入力してE２セルまで右にドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(Sheet1!$F:$F),"",IF(INDEX(Sheet1!$A:$E,MATCH(ROW(A1),Sheet1!$F:$F,0),COLUMN(A1))="","",INDEX(Sheet1!$A:$E,MATCH(ROW(A1),Sheet1!$F:$F,0),COLUMN(A1))))

お礼

ご回答ありがとうございます。無事、反映することができました。
式もシンプルでわかりやすく大変助かりました。

回答No.1

ki-aaa

試してみて

テストデータはSheet1に在り、
Sheet2に書き出しています。

Sub ペアを見つけ出し削除()
Const 差の値 As Long = 960
Dim dic As Object
Dim maxRow As Long
Dim i As Long, j As Long
Dim myKey
Dim myArray

Sheets("Sheet1").Select
maxRow = Cells(Rows.Count, "C").End(xlUp).Row

ReDim myArray(1 To maxRow, 1 To 5)

Set dic = CreateObject("scripting.dictionary")

For i = 1 To maxRow
myKey = Cells(i, "D").Value
If dic.exists(myKey) Then
j = dic(myKey)
If Cells(i, "C").Value = "off" Then
If Cells(i, "B").Value - myArray(j, 2) > 差の値 Then
myArray(j, 1) = ""
myArray(j, 2) = ""
myArray(j, 3) = ""
myArray(j, 4) = ""
Else
myArray(j, 5) = Cells(i, "B").Value - myArray(j, 2)
myArray(i, 1) = Cells(i, "A").Value
myArray(i, 2) = Cells(i, "B").Value
myArray(i, 3) = Cells(i, "C").Value
myArray(i, 4) = Cells(i, "D").Value
End If
dic.Remove myKey
ElseIf Cells(i, "C").Value = "on" Then
MsgBox "ペアが成立しません。　データを見直してください on " & i & " 行"
Exit Sub
End If

Else
If Cells(i, "C").Value = "off" Then
MsgBox "ペアが成立しません。　データを見直してください off " & i & " 行"
Exit Sub
ElseIf Cells(i, "C").Value = "on" Then
dic(myKey) = i
myArray(i, 1) = Cells(i, "A").Value
myArray(i, 2) = Cells(i, "B").Value
myArray(i, 3) = Cells(i, "C").Value
myArray(i, 4) = Cells(i, "D").Value
End If
End If
Next i

Set dic = Nothing

j = 0
For i = 1 To maxRow '行の削除
If myArray(i, 3) <> "" Then
j = j + 1
myArray(j, 1) = myArray(i, 1)
myArray(j, 2) = myArray(i, 2)
myArray(j, 3) = myArray(i, 3)
myArray(j, 4) = myArray(i, 4)
myArray(j, 5) = myArray(i, 5)
End If
Next i

If j > 0 Then
Sheets("Sheet2").Cells.ClearContents
Sheets("Sheet2").Cells(2, 1).Resize(j, 5).Value = myArray
End If
End Sub

お礼

ご解答頂き、ありがとうございます。マクロということで非常に助かります。
書き忘れて申し訳ありませんが、私の環境はMacなのでactive xとやらが使えないみたいなので、このマクロをmac用に変換する方法を探っていきたいと思います。
ありがとうございます。