VBAにて複数の重複データを取得したい

質問

VBAにて以下のような処理を考えているのですが・・。

ある列(Aとします)が以下のような時。
abc
aaa
abc
aaa
ddd
このときにabc、aaaは重複しているぞっとわかるような
処理がしたいのですが・・・。

回答No.4

bikkuri · ベストアンサー

Excellの機能を使わず、VBAのプログラムでの処理例です。

Sub ボタン1_Click()
Dim i As Long, n As Long
Dim s As String, co As Collection
Dim t As Double

Set co = New Collection
Range("b:b").Value = "" 'B列を全てクリア
t = Timer
For i = 1 To 30000 '適当に上限を30000にした
s = Cells(i, 1).Value
If s = "" Then Exit For
On Error Resume Next
co.Add s, s
If Err Then
On Error GoTo 0
Cells(i, 2).Value = "重複"
n = n + 1
End If
On Error GoTo 0
Next
MsgBox "件数=" & i - 1 & " 重複件数=" & n & " 時間=" & Timer - t
End Sub

A列の１行目から順に空セルを見つけるまでチェックします。
現在のセルの値が既に存在していれば（上にあれば）B列に重複の文字を設定します。

実行時間は、重複するデータの比率により変わりますが、
重複13%で20秒、67%で80秒でした。
（実行環境は、Pen3 500MHz, Excel97）

しかし、"重複"の文字をセルに表示しなければ（該当部分をコメントアウト）
5～7秒位でした。（結構セルへの表示に時間がかかっている！）

回答No.3

imogasi

#1です。
＞処理がちょっと遅いですね・
それを気にして、総なめにしないで、FINDを使ったのですが、３万行では時間が掛かりますか。
少しでも改善しないかと思って、良ければ下記をやって見て下さい。
Sub test01()
Dim x As Range
Application.ScreenUpdating = False '追加
Application.Calculation = xlManual '追加
d = Range("A1").CurrentRegion.Rows.Count
' MsgBox d
For i = 1 To d - 1
If Cells(i, "A") = "重複" Then Exit For '追加
Set x = Range(Cells(i + 1, "A"), Cells(d, "A")).Find( _
what:=Cells(i, "A"), LookIn:=xlValues, lookat:=xlPart)
If Not (x Is Nothing) Then
Cells(i, "B") = "重複"
Cells(x.Row, "B") = "重複"
End If
Next i
Application.ScreenUpdating = False "追加
Application.Calculation = xlAutomatic '追加
End Sub

回答No.2

Silent-G

Excelの機能を使ってやってみるとこんな感じかな。
そんなに遅くないと思いますが、わかりません。
# うちのマシン早いから(^^;)

Sub 重複を洗い出す()
Dim wb As Excel.Workbook
Dim pt As Excel.PivotTable
Dim sh As Excel.Worksheet
Dim rg As Excel.Range

Dim HeadName As String
Dim dat As Variant

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set sh = ActiveSheet
HeadName = sh.Cells(1, 1).Value

'ピボットテーブルを作る
With wb
Set pt = .PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:=sh.Cells(1, 1).CurrentRegion.Address _
).CreatePivotTable(TableDestination:="", TableName:="Pivot")
End With

Set sh = ActiveSheet

With pt
.SmallGrid = False
.ColumnGrand = False
.RowGrand = False
.AddFields (HeadName)
.PivotFields(HeadName).Orientation = xlDataField
End With

'ピボットテーブルからデータだけを取り出す
With sh
Set rg = .Range(.Cells(2, 1), .Cells(2, 1).SpecialCells(xlLastCell))
dat = rg.Value
.Columns("A:B").Delete Shift:=xlToLeft
End With
rg.Offset(-1, 0).Value = dat

'オートフィルターで重複データを見つける
With sh.Cells(1, 1)
.CurrentRegion.AutoFilter Field:=2, Criteria1:=">=2"
.CurrentRegion.Copy
End With

'新しいシートに重複データだけコピーする
wb.Sheets.Add
With ActiveSheet
.Paste
.Name = "重複項目"
.Columns("B").Delete Shift:=xlToLeft
With .Cells(1, 1)
.Value = "重複項目"
.Select
End With
End With

Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = False

Set wb = Nothing
Set pt = Nothing
Set sh = Nothing
Set rg = Nothing

End Sub

注意：データはA列だけに空行なしで存在していて、１行目にヘッダーがあると仮定しています。

回答No.1

imogasi

色々なロジックが考えられると思いますが、一例を挙げます。
今注目している行の値について、直下行から最下行までに
同じものが見つかるか、Ｆｉｎｄメソッドを使って見つけて、B列にコメントを入れてます。
最下行の１つ手前まで繰り返します。
Sub test01()
Dim x As Range
d = Range("A1").CurrentRegion.Rows.Count
' MsgBox d
For i = 1 To d - 1
Set x = Range(Cells(i + 1, "A"), Cells(d, "A")).Find( _
what:=Cells(i, "A"), LookIn:=xlValues, lookat:=xlPart)
　If Not (x Is Nothing) Then
　　Cells(i, "B") = "重複"
　　Cells(x.Row, "B") = "重複"
　End If
Next i
End Sub
（テストデータ）
aaa 重複
bbb
ccc 重複
aaa 重複
ccc 重複
ddd
ggg
hhh
s 重複
dfg
fgh
ccc 重複
s 重複

お礼

ありがとうございます。
実際やってみましたがデータが3万件ほどになると
処理がちょっと遅いですね・・・。
しょうがないですかね・・・。