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

2013/08/16 10:54

このQ&Aのポイント

質問文章では、特定の条件を満たす行のペアを見つけて削除したいという要件があります。
具体的には、C列に「on」というテキストが入り、D列に整数の値がある行のペアを見つけ、そのペアに関連する行を削除したいとのことです。
このペアは、C列に「off」というテキストが入り、D列にも値が入っている行である必要があります。

tukutukuhosi
お礼率92% (50/54)

その他MS Office製品
回答数2
ありがとう数3

みんなの回答 （2）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

KURUMITO
ベストアンサー率42% (1835/4283)

2013/08/17 09:05 回答No.2

関数を使って対応する方法です。シート１にお示しのようなデータが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))))

質問者

お礼 2013/08/18 15:58

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

ログインすると、全ての回答が全文表示されます。

その他の回答 (1)

ki-aaa
ベストアンサー率49% (105/213)

2013/08/16 22:43 回答No.1

試してみてテストデータは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

質問者