エクセルの重複データの抽出（条件付）

エクセルの以下のようなデータから３時間以上連続で出現しているデータを抽出してその行に色をつけるようなマクロを組みたいのですがそのような方法はないでしょうか。

Ａ列　　　Ｂ列
6/1 3:00 ＡＡＡ社
6/1 3:00 ＢＢＢ社
6/1 3:00 ＣＣＣ社
6/1 2:00 ＡＡＡ社
6/1 2:00 ＣＣＣ社
6/1 2:00 ＤＤＤ社
6/1 1:00 ＡＡＡ社
6/1 1:00 ＤＤＤ社
6/1 1:00 ＥＥＥ社
6/1 1:00 ＦＦＦ社
6/1 1:00 ＧＧＧ社
6/1 0:00 ＡＡＡ社
6/1 0:00 ＢＢＢ社
6/1 0:00 ＣＣＣ社
6/1 0:00 ＤＤＤ社
6/1 0:00 ＧＧＧ社
6/1 0:00 ＨＨＨ社
・
・
・

Ａ列は日時、Ｂ列は企業名です。
Ｂ列の企業名が３時間以上連続して出現している行を抽出して、その行（または企業名）に色をつけるか、または重複してる企業名の一覧表示をしたいです。
この例の場合、ＡＡＡ社とＤＤＤ社になります。
（ＣＣＣ社は３回出現してるけど、3時間連続していないので対象外。）
３時間以上連続して出現というのがポイントです。
データは２０００行ほどで、24時間分です。
マクロ初心者でいろいろ検索してみたのですが、わからずすごく困っています。よろしくお願いします。

No.1 ベストアンサー 回答者： hallo-2007 回答日時： 2008/06/06 14:21

VBAではありませんが、もし

Ａ列　　　Ｂ列
2008/6/1 0:00ＡＡＡ社
2008/6/1 0:00ＢＢＢ社
2008/6/1 0:00ＣＣＣ社
2008/6/1 0:00ＤＤＤ社
2008/6/1 0:00ＧＧＧ社
2008/6/1 0:00ＨＨＨ社
2008/6/1 1:00ＡＡＡ社
2008/6/1 1:00ＤＤＤ社
2008/6/1 1:00ＥＥＥ社
2008/6/1 1:00ＦＦＦ社
2008/6/1 1:00ＧＧＧ社
2008/6/1 2:00ＡＡＡ社
2008/6/1 2:00ＣＣＣ社
2008/6/1 2:00ＤＤＤ社
2008/6/1 3:00ＡＡＡ社
2008/6/1 3:00ＢＢＢ社
2008/6/1 3:00ＣＣＣ社
のように日時を昇順に並び替えてよいのでしたら、Ｃ列に
=COUNTIF(B2:INDEX(A:B,MATCH(A2+2/24,A:A),2),B2)
入れて下フィル　3時間以内に何度同じ会社名がでるか表示します。
３が出たものが対象です。
これでよければ、条件付書式に応用してみてください。

この回答へのお礼

早い回答ありがとうございました。
エクセルの関数で3時間連続の判定ができるんですね。大変参考になりました。
マクロでC列に入れれば自動で判定できそうですね。
ありがとうございます！！

お礼日時：2008/06/09 10:45

No.2 回答者： mitarashi 回答日時： 2008/06/07 01:37

小難しい方法しか思いつきませんでした。

久しぶりにクラスを使用して、随分時間がかかってしまいました。こんなのを理解しようとするよりは、並び替えて自分の目で確認した方がずっと早い．．．
Ａ，Ｂ列の先頭からデータが入っている事を前提にしています。セルの着色＋該当する社名をＤ列に表示します。A No.1の方がGoodですよね。ご参考まで。
＜標準モジュール＞
Sub test()
Dim myDic As Object, myKey As Variant
Dim rng As Range
Dim targetRange As Range
Dim myCells() As myCellClass
Dim clsCounter As Long
Dim i As Long, j As Long

Set targetRange = ActiveSheet.Range("a1").CurrentRegion.Columns(1)
Set myDic = CreateObject("Scripting.Dictionary")
ReDim myCell(0 To 0)
For i = 1 To targetRange.Cells.Count
Set rng = targetRange.Cells(i)
If Not myDic.exists(rng.Offset(0, 1).Value) Then
clsCounter = UBound(myCell) + 1
ReDim Preserve myCells(0 To clsCounter)
Set myCells(clsCounter) = New myCellClass
myCells(clsCounter).add rng
myDic.add rng.Offset(0, 1).Value, myCells(clsCounter)
Else
myDic.Item(rng.Offset(0, 1).Value).add rng
End If
Next i
'
myKey = myDic.keys
j = 0
For i = 0 To myDic.Count - 1
If myDic.Item(myKey(i)).flag = True Then
ActiveSheet.Range("D1").Offset(j, 0).Value = myKey(i)
j = j + 1
End If
Next i
Set myDic = Nothing
End Sub

＜クラスモジュール＞　クラス名：myCellClass
Private myGroup() As Range
Private groupCounter As Long
Private lastRange As Range
Private myFlag As Boolean

Private Sub Class_Initialize()
groupCounter = 1
ReDim myGroup(1 To 1)
End Sub

Public Sub add(newRange As Range)
If myGroup(groupCounter) Is Nothing Then
Set myGroup(groupCounter) = newRange
Else
If DateDiff("h", newRange.Value, lastRange.Value) = 1 Then
Set myGroup(groupCounter) = Union(myGroup(groupCounter), newRange)
If myGroup(groupCounter).Cells.Count >= 3 Then
myGroup(groupCounter).Interior.ColorIndex = 6
myGroup(groupCounter).Offset(0, 1).Interior.ColorIndex = 6
myFlag = True
End If
Else
groupCounter = UBound(myGroup) + 1
ReDim Preserve myGroup(1 To groupCounter)
Set myGroup(groupCounter) = newRange
End If
End If
Set lastRange = newRange
End Sub

Public Function flag() As Boolean
flag = myFlag
End Function

この回答へのお礼

ありがとうございます。
マクロ（VBA？）超初心者なのでこのプログラムを理解するのは難しそうですが、いつかこんなプログラムをささっと書けるようになれたらすごくかっこいいですね！！少しずつでも、理解して使えるようになっていきたいです。
みなさん、すごいですね。
ありがとうございました。

お礼日時：2008/06/09 10:50