【Excel】重複を除いた抽出方法

質問

以下のような表があります。

No. 項目 ランク 備考
1 AAA 01 あああ
1 AAA 02 いいい
1 AAA 02 ううう
1 AAA 03 えええ
1 AAA 04 おおお
1 AAA 05 かかか
2 BBB 01 ききき
2 BBB 02 くくく
3 CCC 01 けけけ

項目に対してランクがありますが、ひとつの項目に対しランクは「01」「02」「03」「04」「05」しかあってはならないのに、「02」が重複しているものがあります。（例えば3行目は重複しているものとみなされます。備考は違ってもかまいません））
このような重複を省いてデータを抽出したいのです。
抽出の足がかり的なことでもかまいませんので、宜しくお願いいたします。

回答No.5

ka_na_de

一例です。

'===============標準モジュールに記載==============================
Sub test2()
　　Dim myLastRow As Long
　　Dim i As Long

　　Application.ScreenUpdating = False '画面の更新を抑制

　　If IsSheetExist("抽出結果") = True Then
　　　　Application.DisplayAlerts = False
　　　　Worksheets("抽出結果").Delete
　　　　Application.DisplayAlerts = True
　　End If
　　ActiveSheet.Copy after:=Sheets(Sheets.Count)
　　Sheets(Sheets.Count).Name = "抽出結果"

　　With Worksheets("抽出結果")
　　　　myLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　For i = 2 To myLastRow
　　　　　　.Cells(i, "E").Formula = "=B" & i & "&" & "C" & i
　　　　Next i
　　　　For i = myLastRow To 2 Step -1
　　　　　　If Application.CountIf(.Range("E:E"), _
　　　　　　　　　　　　　　　　　　.Cells(i, "E").Value) > 1 Then
　　　　　　　　.Rows(i).Delete
　　　　　　End If
　　　　Next i
　　　　.Columns(5).Delete
　　End With

　　Application.ScreenUpdating = True
End Sub

Function IsSheetExist(argSheetName As String, Optional argWorkbook As Workbook) As Boolean
'シートの存在を確認する関数：存在すればTRUEを返す。
　　Dim myWbk As Workbook
　　Dim mySht As Worksheet

　　If argWorkbook Is Nothing Then
　　　　Set myWbk = ActiveWorkbook
　　Else
　　　　Set myWbk = argWorkbook
　　End If

　　IsSheetExist = False
　　For Each mySht In myWbk.Worksheets　　 '全シートを順に調べる
　　　　If mySht.Name = argSheetName Then　　'同じ名前が見つかれば終了
　　　　　　IsSheetExist = True
　　　　　　Exit For
　　　　End If
　　Next

　　Set myWbk = Nothing
　　Set mySht = Nothing
End Function

回答No.4

kmetu

Sub test()

Dim i, j
Dim Repeated As Boolean

Repeated = False

For i = 1 To Range("A" & Rows.Count).End(xlUp).Row

For j = 1 To Range("F" & Rows.Count).End(xlUp).Row

If Range("B" & i).Value & Range("C" & i).Value = Range("G" & j).Value & Range("H" & j).Value Then
Repeated = True
Exit For
End If

Next j

If Repeated = False Then
Range("A" & i & ":" & "D" & i).Copy
Range("F" & Range("F" & Rows.Count).End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
Repeated = False
End If

Next i

End Sub

上記のマクロでいかがでしょう
FGHI列に結果を書き出します。

回答No.3

tom04

こんにちは！
すでに回答は出ていますが・・・

↓の画像のような表で説明させていただきます。
作業列を2行使っています。

B2セルは
=D2&E2

A2セルは
=IF(B2="","",IF(COUNTIF($B$2:B2,B2)=1,"○","×"))
という数式が入っています。

A2・B2セルを範囲指定し、オートフィルで下へコピーすると
画像のような感じになります。

これで重複しているものに「×」がつきますので

オートフィルタで「○」のものを抽出し、別のところへコピー＆ペーストする方法はどうでしょうか？

尚、元データが変わってもよいのであれば、「×」の行を削除する方法もあります。

以上、参考になれば幸いですが、
他に良い方法があれば読み流してくださいね。m(__)m

回答No.2

KURUMITO

最も簡単には作業列を使うことでしょう。
Ｅ1セルに次の式を入力します。
=B1&C1
F1セルには次の式を入力します。
=IF(E1="","",IF(COUNTIF(E$1:E1,E1)=1,10,0))
E1セルとＦ1セルを選択してから下方にオートフィルドラッグします。
Ｆ列を重点にして降順で並べ替えをすれば重複のデータは0の数値で下方に並びますのでそれらの行を選択してDeleteすればよいでしょう。

回答No.1

noname#96417

2007なら「データ」タブに「重複の削除」があります。

（元データをコピーしてからお使いください。）