エクセル 重複したデータを別シートに抽出させる

お世話になります。

E列の重複したデータを別シートに抽出したいのです。またこの時に
A列とB列にある情報も一緒に抽出する形ができないでしょうか。
（この際 E列にあるハイフンだけのデータはカウントしないものだと助かります）

データsheet に　以下の様なデータがあります。これを
A列　　B列　　E列
A　　202A　 GREEN
A　　203B　 GREEN
A　　204C　　---
B　　505　　RED
B　　505　　RED
C　　312　　---
C　　312　　-
C　　313　　-

重複sheet に　以下の様な結果になるよう抽出したいと考えています。
A列　　B列　　E列
A　　202A　 GREEN
A　　203B　 GREEN
B　　505　　RED
B　　505　　RED

何卒ご助力のほど、よろしくお願い致します。

質問者からの補足コメント

• 

  EXCEL2003 を使用しております。できればVBA を使用して解決できれば、と希望しています。
  
  よろしくお願い致します。

    補足日時：2016/06/23 15:51

No.9 ベストアンサー 回答者： picopico_7 回答日時： 2016/06/24 13:52

No.4です。

またまたこんにちは。
遅くなりました。
オートフィルターで表示されているデータのみを対象に、今までの処理をするというコードを作ってみました。
結構変更したので改めてコードを貼り付けますね。
ちなみに作業列(F列)の使用は廃止しました。
私の低いコーディング技術で１つのプロシージャ内に納めたものなので読みにくいと思いますが頑張って読んでみてください(笑)
心配なのはデータ量が多い場合フリーズしないか、ということです・・・。

Public Sub b()

Dim r1 As Double
Dim r2 As Double
Dim rLST As Double
Dim cntR As Double
Dim cntA As Double
Dim cnt As Double
Dim i As Integer
Dim pick1()
Dim pick2()
Dim colE()

'//-----シート名の指定----
Const SNM1 = "Sheet1"
Const SNM2 = "Sheet2"
'------------------------//

'//-----シート1データ開始行指定----
Const srt1 = 2
'--------------------------------//

'//-----シート2データ貼付行指定----
Const srt2 = 2
'--------------------------------//

'シート1のデータ最終行を取得
Worksheets(SNM1).Select
Worksheets(SNM1).Range("A" & srt1).Select
Selection.End(xlDown).Select
rLST = ActiveCell.Row

r1 = srt1
cntR = 1
Do Until r1 > rLST
'選択行が可視の時
If Sheets(SNM1).Rows(r1).Hidden = False Then
'E列の値が「-」かつ「---」でない時
If Worksheets(SNM1).Range("E" & r1) <> "-" And Worksheets(SNM1).Range("E" & r1) <> "---" Then
'行番号を取得
ReDim Preserve pick1(cntR)
pick1(cntR) = r1
'E列の値を取得
ReDim Preserve colE(cntR)
colE(cntR) = Range("E" & r1)
cntR = cntR + 1
End If
End If
r1 = r1 + 1
Loop

'対象行(可視＆E列がハイフンでない)内でのＥ列重複確認
cntR = 1
For cntA = 1 To UBound(pick1)
i = 0
For cnt = 1 To UBound(colE)
If Worksheets(SNM1).Range("E" & pick1(cntA)) = colE(cnt) Then
i = i + 1
'重複が1つでもあったら比較処理を終了(時短対策)
If i > 1 Then
Exit For
End If
End If
Next

'重複の行番号を取得
If i > 1 Then
ReDim Preserve pick2(cntR)
pick2(cntR) = pick1(cntA)
cntR = cntR + 1
End If
Next

'シート2へコピペ
r2 = srt2
For cnt = 1 To UBound(pick2)
Worksheets(SNM1).Rows(pick2(cnt) & ":" & pick2(cnt)).Copy
Worksheets(SNM2).Select
Worksheets(SNM2).Rows(r2 & ":" & r2).Select
ActiveSheet.Paste
r2 = r2 + 1
Next

'アクティブセルをA1にしておく
Worksheets(SNM1).Select
Application.CutCopyMode = False
Worksheets(SNM1).Range("A1").Select
Worksheets(SNM2).Select
Worksheets(SNM2).Range("A1").Select

End Sub

この回答へのお礼

picopico_7様

ありがとうございました。
どのように御礼の言葉を綴ればいいのか、分からない程です。
私自身ももう少し勉強をしていきたいと思います。

お礼日時：2016/06/24 17:50

No.8 回答者： WindFaller 回答日時： 2016/06/23 18:33

こちらへも失礼します。

ほとんど同じパターンのマクロが続いていますから、ここも参加させていただきます。
一応、これでも、マクロの練習です。私の苦手だったDictionary もだいぶわかってきたような気がしますが、この先に、まだ、同様のオブジェクトがありますから、まだまだ、先は長いです。

'//
Sub PickingWData()
　Dim objDic As Object
　Set objDic = CreateObject("Scripting.Dictionary")
　Dim i As Long, j As Long, k As Long, s As String
　Dim arBuf As Variant, rngBuf As Variant
　Dim LastRw As Long
　Dim Ws1 As Worksheet
　Dim Ws2 As Worksheet
　'***********
　'設定
　Set Ws1 = Worksheets("データ")
　Set Ws2 = Worksheets("重複")
　'**********
　With Ws1
　　　LastRw = .Cells(Rows.Count, 1).End(xlUp).Row
　　　k = 1
　　　For i = 1 To LastRw
　　　　　If .Cells(i, "E").Value Like "*[A-Z]*" Then '大文字アルファベットがあること
　　　　　　　s = Trim(.Cells(i, "E").Value)
　　　　　　　If Not objDic.Exists(s) Then
　　　　　　　　　objDic.Add Trim(.Cells(i, "E").Value), .Cells(i, 1).Address(0, 0)
　　　　　　　Else
　　　　　　　　　objDic(Trim(.Cells(i, "E").Value)) = objDic(Trim(.Cells(i, "E").Value)) & "," & _
　　　　　　　　　.Cells(i, 1).Address(0, 0)
　　　　　　　End If
　　　　　End If
　　　Next i
　　　arBuf = objDic.Items
　　　For i = LBound(arBuf) To UBound(arBuf)
　　　　　If InStr(1, arBuf(i), ",") > 0 Then
　　　　　　　rngBuf = Split(arBuf(i), ",")
　　　　　　　For j = LBound(rngBuf) To UBound(rngBuf)
　　　　　　　　　.Range(rngBuf(j)).Resize(, 5).Copy Ws2.Cells(k, 1)
　　　　　　　　　k = k + 1
　　　　　　　Next j
　　　　　　　Erase rngBuf
　　　　　End If
　　　Next i
　　End With
　　If k > 1 Then
　　　　MsgBox (k - 1) & " 個抽出 - 終了", vbInformation
　　End If
　　Set objDic = Nothing
End Sub
'//

この回答へのお礼

WindFaller様　

こんなところまで！ありがとうございます。
できればE列には数字やアルファベット
Then '大文字アルファベットがあること　限定せず
数字や小文字大文字アルファベット含めたい、ことを希望しています。。

お礼日時：2016/06/23 19:31

No.7 回答者： picopico_7 回答日時： 2016/06/23 16:44

No.4です。

①⇒出来ます。が、今日は時間がない為明日でしたらまたお手伝い出来るのですが。お急ぎの様でしたら①の内容でのトピを改めて立てられると回答してくれる人がいると思います。

②⇒すみません。F列の数式は最後に消しておいた方良いですよね。
先ほどのコードに以下「★」行を追加してやってください。
Worksheets(SNM1).Select
★Worksheets(SNM1).Columns("F:F").Select
★Selection.ClearContents
Worksheets(SNM1).Range("A1").Select
Worksheets(SNM2).Select
Worksheets(SNM2).Columns("F:F").Select
Selection.ClearContents
Worksheets(SNM2).Range("A1").Select

この回答へのお礼

picopico_7様

お忙しい中、本当にありがとうございます。
お気持ちに感謝いたします。

急いでいませんし、picopico_7様にお付き合い
頂ければと思います。
またよろしくお願い致します。

お礼日時：2016/06/23 16:58

No.6 回答者： picopico_7 回答日時： 2016/06/23 16:22

No.4です。

失礼しました。
こちらでは1行目からデータを入れて動かしておりました。
データのスタート行を変えたい時はコード中の「r1 = 1」を1から任意の数字に変えてやってください。
ちなみに貼り付け先のスタート行は「r2 = 1」の箇所です。

この回答へのお礼

いえ、本当にありがとうございます。

心苦しいのですが、もし可能でしたら以下も併せて
教えて頂けないでしょうか。

①スタート行をオートフィルタで絞り込んだ１行目から
にする設定などに変えることはできますでしょうか？
②またF列を作業列　をsheet2のF列に移す、あるいは
sheet1に表示させないことはできますでしょうか？

お礼日時：2016/06/23 16:28

No.5 回答者： picopico_7 回答日時： 2016/06/23 16:03

No.4です。

シート１から２に遷移するだけになってますか？
そうするとシート１から２へのコピペがうまくいっていないか、そもそも重複データは無しと認識されているかかなぁ？
ちなみにこちらではnotimeさんが質問の文中に書かれたデータをそのままテストデータとして使用しうまくいっています。
ステップイン実行で1行ずつ確認してみることは出来ますか？

この回答へのお礼

picopico_7様

ありがとうございます。
1行目からデータが入っていないと認識しないのですね。
VBA初心者であり、申し訳ありませんでした。
うまくいきました。ありがとうございました。

お礼日時：2016/06/23 16:18

No.4 回答者： picopico_7 回答日時： 2016/06/23 13:52

こんにちは。

VBAを使用しても大丈夫でしたか？
大丈夫な様でしたらこんなのはいかがでしょう？
ちなみにデータsheetのF列を作業列として使用しておりますので都合が悪い様でしたら「 '//-----作業列の指定----」で指定しているFを違う列に変更してください。
またE列には連続して値が入っているものとし、空欄が出て来た時点でデータは終了と認識しています。
VBAは使用したくないというようでしたらスルーして頂いて結構です。
VBAは使用ても良いけれど認識が違っている、などあれば補足で書いてください。

Public Sub a()

Dim r1 As Double
Dim r2 As Double
Dim cntALL As Double
Dim cnt As Double

'//-----シート名の指定----
Const SNM1 = "Sheet1"
Const SNM2 = "Sheet2"
'------------------------//

'//-----作業列の指定----
Const workR = "F"
'------------------------//

r1 = 1
'E列の値の入力がなくなるまでの繰り返し処理
Do Until Worksheets(SNM1).Range("E" & r1) = "" Or IsNull(Worksheets(SNM1).Range("E" & r1))
'E列の値が「-」または「---」の時はF列に0を入力
If Worksheets(SNM1).Range("E" & r1) = "-" Or Worksheets(SNM1).Range("E" & r1) = "---" Then
Worksheets(SNM1).Range(workR & r1) = 0
'そうでない時はF列に数式を入力
Else
Worksheets(SNM1).Range(workR & r1) = "=COUNTIF(E:E,E" & r1 & ")"
End If
r1 = r1 + 1
Loop
cntALL = r1 - 1

r1 = 1
r2 = 1
For cnt = 1 To cntALL
'F列の値が1より大きい時は別シートに行貼り付け
If Worksheets(SNM1).Range(workR & r1) > 1 Then
Worksheets(SNM1).Rows(r1 & ":" & r1).Copy
Worksheets(SNM2).Select
Worksheets(SNM2).Rows(r2 & ":" & r2).Select
ActiveSheet.Paste
r2 = r2 + 1
End If
r1 = r1 + 1
Next

Worksheets(SNM1).Select
Worksheets(SNM1).Range("A1").Select
Worksheets(SNM2).Select
Worksheets(SNM2).Columns("F:F").Select
Selection.ClearContents
Worksheets(SNM2).Range("A1").Select

End Sub

この回答へのお礼

ご回答ありがとうございます。
質問には可能性を広げたくVBA 限定とはしていませんでしたが、
VBA を使って作業をしたいと考えております。

そこで、ご回答内容のコードを試してみたのですが、
うまく作動しません（デバックするわけではなく、Sheet1 からSheet2に
画面が移動するだけ）。
ちなみにexcel2003 を使用しております。
もし宜しければ、再度ご教授お願いしてもいいでしょうか。
何卒よろしくお願い致します。

お礼日時：2016/06/23 15:51

No.3 回答者： mike_g 回答日時： 2016/06/23 13:02

》 E列の重複したデータを別シートに抽出…

「GREEN」と「RED」は理解できるけど、
「-」も「E列の重複したデータ」でしょ！
「---」も疑わしい！
紛らわしいデータは載せないでぇ～

この回答へのお礼

ご回答ありがとうございます。

質問の５行目にあります通り、ハイフン「-」だけのデータは
除いたものを希望しております。

紛らわしかったでしょうか。
もしそれでご回答頂けるなら、お願い致します。
できればVBAを使用したものを希望しております。

お礼日時：2016/06/23 15:44

No.2 回答者： くんこば 回答日時： 2016/06/23 12:45

手作業で？VBA？

この回答へのお礼

解決するなら、どのような手法でも構いません。
よろしくお願い致します。

お礼日時：2016/06/23 15:42

No.1 回答者： banzaiA 回答日時： 2016/06/23 12:00

フィルター機能を使えばできます。

この回答へのお礼

ありがとうございます。
もう少し詳しく教えて頂けますと幸いです。
質問内容には書きませんでしたが、できれば
VBA 等で１クリックで操作できる形になれば
と希望しております。

お礼日時：2016/06/23 15:42