お助け下さい、プログラミングの分かる方！！

ヘルプをお願い致します。

あるデータ一覧の中に重複したデータと重複していないデータがあります。
リストアップしたいのは、重複していないデータと重複したものはその最新の
日付（現在から考えて）のものだけデータをリストアップしたいのです。


下記をネットから調べて見つけたのですが、肝心の最新の日付をみて
重複データがリストアップできずに大変困っています。


お手数をおかけ致しますが、助けて頂きますようお願い致します。

重複チェックは、顧客名と製品名でしたいと考えています。
リストアップは別のシートにリストアップできればと考えています。
重複していたデータには色がついていると助かります。

マクロ初心者なので、簡単な説明文を頂けると大変助かります。


＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

データは下記です。

　A　　　　　B　　　　　　C　　　　　D　　　　E　　　　F　　　　　　G
日付　　顧客名　　製品名　　担当者　　価格　　個数　　合計金額

1/1 田中さん　　Ａ　　　　担当者Ａ　　１００円　１００　１００００
1/2　　 田中さん　　Ｂ　　　　担当者Ｂ　　１００円　１００　１００００
1/3　　 鈴木さん　　Ｂ　　　　担当者Ｃ　　１００円　１００　１００００

１０００行以上あります。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub ko()

Dim x As Long 'xは長整数と宣言
With ActiveSheet 'アクティブなシートで
.Rows("1").Insert Shift:=xlDown 'ダミー行挿入
.Range("A1") = "Code" 'ダミー項目１
.Range("B1") = "Name" 'ダミー項目２
x = .Cells(.Rows.Count, 1).End(xlUp).Row '最終行取得
.Range("A1:B" & x).Select '範囲選択
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True '重複を表示しない
Selection.Copy .Range("C1") 'コピーしてC1以降に貼り付け
.ShowAllData 'すべてを表示
.Rows("1").Delete Shift:=xlUp 'ダミー行削除
End With

End Sub

No.2 ベストアンサー 回答者： Randomize#1 回答日時： 2011/09/18 19:26

条件付きで重複行を処理したい場合はDictionaryオブジェクトの使用をお勧めします。

まずはプログラムソースから

'=====プログラムここから=====

Public Sub DoSyuukei()
Dim objDicNameList As Object
Dim NowReadRow As Long, MaxReadRow As Long
Dim NowReadCol As Long, MaxReadCol As Long
Dim NowIndex As Long, MaxIndex As Long
Dim NowWriteRow As Long
Dim objOutputRange As Range
Dim objSrcSheet As Worksheet
Dim varRangeWriteData() As Variant
Dim varResultArray As Variant
Dim strTemp As String

'=====設定部分=====
'元のデータを読み込みたいシートを指定
Set objSrcSheet = ThisWorkbook.Worksheets("Sheet1")

'結果を出力する部分の左上を指定
Set objOutputRange = ThisWorkbook.Worksheets("Sheet2").Range("A1")

'=====プログラム本体=====
'今回のミソ、Dictionaryオブジェクトの宣言
Set objDicNameList = CreateObject("Scripting.Dictionary")
'念のため全消去(なくてもOK)
objDicNameList.RemoveAll
'最終行を取得
MaxReadRow = objSrcSheet.Cells(objSrcSheet.Rows.Count, 1).End(xlUp).Row
'2行目から順に内容を解析していく(1行目はタイトルだから行わない)
For NowReadRow = 2 To MaxReadRow
'重複をチェックするのは顧客名と製品名の2個なので、この2個をタブ文字でつないだ文字列で重複チェックを行う
strTemp = objSrcSheet.Cells(NowReadRow, 2).Value & vbTab & objSrcSheet.Cells(NowReadRow, 3).Value
'この作成した文字がすでに出てきたかをチェックする
If objDicNameList.Exists(strTemp) = True Then
'登録されている場合は、登録されているデータの日付を読みだしてチェックする
'同じ日付である場合は下にある方が優先(「>=」を「>」にすると上にある方が優先になります)
If objSrcSheet.Cells(NowReadRow, 1).Value >= objDicNameList.Item(strTemp)(0) Then
'今読んでいるデータの方が新しい場合のみデータを再登録する(さらに重複回数を+1する)
objDicNameList.Item(strTemp) = Array(objSrcSheet.Cells(NowReadRow, 1).Value, NowReadRow, objDicNameList.Item(strTemp)(2) + 1)
Else
'データが新しくない場合は重複回数を+1するのみ
objDicNameList.Item(strTemp) = Array(objDicNameList.Item(strTemp)(0), objDicNameList.Item(strTemp)(1), objDicNameList.Item(strTemp)(2) + 1)
End If
Else
'登録されてない場合
'登録されていない場合は新規に登録する　(日付,データのあるExcelの行番号,重複回数)の3個のデータを格納する
objDicNameList.Add strTemp, Array(objSrcSheet.Cells(NowReadRow, 1).Value, NowReadRow, 0)
End If
Next
'調査結果に従って結果を作成する
MaxIndex = objDicNameList.Count '何種類データがあったかを取得
'元のデータは何列データがあるかを取得( =3 などのように手で指定してもOK)
MaxReadCol = objSrcSheet.Cells(1, objSrcSheet.Columns.Count).End(xlToLeft).Column
'結果を入れる用の作業用データ領域を作成(こうすることで高速化が可能)
'見出し行のため1行多く設定する。更に重複であることを記入する場所のため、列も1列多く宣言する
ReDim varRangeWriteData(1 To MaxIndex + 1, 1 To MaxReadCol + 1)
'タイトル行を複写
For NowReadCol = 1 To MaxReadCol
varRangeWriteData(1, NowReadCol) = objSrcSheet.Cells(1, NowReadCol).Value
Next
varRangeWriteData(1, MaxReadCol + 1) = "重複回数" '重複回数の列タイトルを作成
'集計した結果を変数に吐き出しする
varResultArray = objDicNameList.Items
'objdicNameListの中に記録した行のデータを元にセルのデータを作成していく
NowWriteRow = 2 '1行目は見出し行なので2行目から開始
For NowIndex = 1 To MaxIndex
'元シートから読み込むべき行番号を取り出す
NowReadRow = varResultArray(NowIndex - 1)(1)
'読み出すべき行番号を元にその場所のデータを複写する
For NowReadCol = 1 To MaxReadCol
varRangeWriteData(NowWriteRow, NowReadCol) = objSrcSheet.Cells(NowReadRow, NowReadCol).Value
Next
'重複データであった場合は重複回数を書きだす
If varResultArray(NowIndex - 1)(2) > 0 Then
varRangeWriteData(NowWriteRow, MaxReadCol + 1) = varResultArray(NowIndex - 1)(2)
End If
'書きだす場所を次の行に変更
NowWriteRow = NowWriteRow + 1
Next
'作成したデータを貼り付けるのにどのくらいの大きさのセル範囲が必要かを計算して指定する
With objOutputRange.Worksheet.Range(objOutputRange, objOutputRange.Offset(UBound(varRangeWriteData, 1) - 1, UBound(varRangeWriteData, 2) - 1))
'作成したデータをExcelに貼り付け
.Value = varRangeWriteData

'.Sort "顧客名", , "製品名", , , , , xlYes '結果をソートしたければコメント解除して編集してください。左は顧客と製品名でソート
End With
'出したものはお片づけ
Set objOutputRange = Nothing
Set objDicNameList = Nothing
Set objSrcSheet = Nothing
End Sub

'=====プログラムここまで=====

Dictionaryオブジェクトを用いることにより、Exists(調べたい文字)とするだけで過去にその文字を登録したことがあるかを一発で調べることができます。詳しく知りたい場合は、[vba dictionary]さらに原理を知りたい場合は[連想配列]のあたりで検索をするといいでしょう。参考になるURLを3つほど紹介しておきます。

http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …
http://officetanaka.net/excel/vba/tips/tips80.htm
http://www.php-labo.net/tutorial/php/hash.html　(言語がVBでなくPHPだが、絵の雰囲気で解説するので良ければ参考に)

さらにもう1個、これは説明しているサイトが少ないですが、Dictionaryオブジェクトは格納できるのは値1個だけではなく、配列をそのまま格納することができてしまいます。Array(○○,△△)のように。それを用いて最新の日付はいつとか何回重複したかなどを実現しています。
文字数制限の関係で詳しく解説出来なかったですが、今後の参考とステップアップの糧になれば幸いです。

この回答へのお礼

誠にありがとうございました。

一言、完璧！！でした。

本当にありがとうございます。
検証するのに時間がかかり、
お礼のメールが遅れてしまい、申し訳ありませんでした。

でも、Dictionaryオブジェクトは難しいですね。
本当にこれだけ丁寧に解説頂いてやっと
利用できたという感じです。

これからもすこしづつ頑張っていきたいと思いますので、
機会がありましたら、またお助け下さい。
宜しくお願い致します。

お礼日時：2011/09/23 13:35

No.1 回答者： imogasi 回答日時： 2011/09/18 18:23

（１）していしなければ、関数でも回答が出そうだが、式は長く複雑な式になる。

（２）ＶＢＡでも２列の条件を満たす行を抜き出すのでも、難しい。２列を結合した列を新たに作れば出来ないことは無いが。
ＡＣＣＥＳＳなどでのＳＱＬなら２条件、３条件でもＡＮＤ条件でＳＥＬＥＣＴはたやすい。エクセルからＳＱＬを使えるから、中級者ならそちらを考える人もいるかも。（MSクエリ）。
またばらばらだと顧客＋製品で、同じものの日付の新しいものも抜き出すのも簡単ではない。
ーー
一番簡単と思うのは、ＶＢＡを使っての「ソート法」だろう。
（１）まずシートのコピーを別に作る。以下コピー側で話する。（元のシートを温存するため）
（２）下記条件でソート
　　顧客名列
　　製品名列
　　日付列
この優先順序で昇順に指定してソート。
すると顧客名＋製品名で同じものは近接の行に集り、その中で日付的に違うものは最新の行が最後に来る。
ただし日付入力は日付シリアル値であるとする。それなら日付は正整数の大小が日図家日付の前後と同じ意味になる。
これ判りますか。ＶＢＡでなく、エクセルの基礎的知識です。
ーー
例データ　Ｓｈｅｅｔ２
日付顧客名製品名担当者価格個数合計金額
1月4日近藤さんＣ担当者Ｃ10030030000
1月1日田中さんＡ担当者Ａ10010010000
1月5日田中さんＡ担当者Ｄ20010020000
1月7日田中さんＡ担当者Ｆ10010010000
1月2日田中さんＢ担当者Ｂ20010020000
1月9日田中さんＣ担当者Ｂ20010020000
1月3日鈴木さんＢ担当者Ｃ30020060000
1月6日鈴木さんＢ担当者Ｃ15040060000
1月8日鈴木さんＣ担当者Ａ5050025000
ーー
標準モジュールに
Sub test01()
Dim sh1, sh2
Set sh1 = Worksheets("Sheet2")
Set sh2 = Worksheets("Sheet3")
d1 = sh1.Range("A65536").End(xlUp).Row
MsgBox d1
k = 2 '2行目から書き出し
'---
For i = 2 To d1 - 1
x = sh1.Cells(i, "B") & sh1.Cells(i, "C")
y = sh1.Cells(i + 1, "B") & sh1.Cells(i + 1, "C") '直下行のキー
If x = y Then
'直下行とキーが同じなら何もしない、読み飛ばし
Else
'直下行とキーが変わっていたら、自身の行の各列を書き出し
For j = 1 To 7
sh2.Cells(k, j) = sh1.Cells(i, j)
Next j
k = k + 1
End If
Next i
'--最終行で,iはFor Nextを抜けたとき１つ進んでいるので
For j = 1 To 7
sh2.Cells(k, j) = sh1.Cells(i, j)
Next j
End Sub
ーーー
結果　Ｓｈｅｅｔ３
見出しの作成とＡ列の日付書式の設定は省略している。補ってください。手動でもよかろう。
2011/1/4近藤さんＣ担当者Ｃ10030030000
2011/1/7田中さんＡ担当者Ｆ10010010000
2011/1/2田中さんＢ担当者Ｂ20010020000
2011/1/9田中さんＣ担当者Ｂ20010020000
2011/1/6鈴木さんＢ担当者Ｃ15040060000
2011/1/8鈴木さんＣ担当者Ａ5050025000
多分この方法が、行数が１番少ないだろう。

この回答へのお礼

返答頂いたのですが、
私の想像した結果になりませんでした。

また次の機会に是非ご協力いただければ
幸いです。

ありがとうございました。

お礼日時：2011/09/23 13:36