エクセルのマクロについて

質問

エクセル97のマクロについて教えてください。

下のようなエクセルシートがあると仮定します。
このシート全体を選択して用意してあるボタンを押すと、マクロが流れるようにします。
マクロの中身は、項目１～４の値が同じであれば、同じデータを一つにするというものを考えています。
たとえば下の例の場合、追番でいえば２と４のデータは同じなので、マクロ処理にかけると、追番の大きい４のデータは消え、２のデータの"200"項目にフラグ１が追加されるようにしたいのです。
項目の値が同じであれば、いくつでもデータを統一したいと考えています。

================ エクセル シート例 ==================================

追番＿項目１＿項目２＿項目３＿項目４＿100＿200＿300＿400 ← 見出し
-----------------------------------------------------------------
1****AAA****BBB****CCC****DDD****1*********1****1****
2****EEE****FFF****CCC****GGG****1**************1****
3****HHH****FFF****KKK****JJJ****1****1****1*********
4****EEE****FFF****CCC****GGG****1****1*********1****

↓ マクロ処理後

追番＿項目１＿項目２＿項目３＿項目４＿100＿200＿300＿400 ← 見出し
-----------------------------------------------------------------
1****AAA****BBB****CCC****DDD****1*********1****1****
2****EEE****FFF****CCC****GGG****1****1*********1****
3****HHH****FFF****KKK****JJJ****1****1****1*********

===================================================================

注:見出しの＿とデータの中の*は空白を生めるためのもので、データとはまったく
関係ありません。

なにぶんエクセルＶＢＡは初心者同然なもので...
よろしくお願い致します。

回答No.2

imogasi

まずロジックを考える習慣をつけること。
（１）ソート法
Ａ．元データに連番を振る。
Ｂ．重複を考えている列でソートする。第２キーはＡで振った連番にする。
Ｃ．重複を考えている列は上からaaabbccc・・・のようになるから上から直前行と同じか判断し、同じだと行削除し、初出行に重複数カウント数に＋１する。
Ｄ。必要あれば連番を第１きーでソートして元の順序に戻す。（勿論行抹消しているから歯抜け状態）
（２）テーブル法
Ａ．重複を考えている列で初出のキーを別列に記録して行く。
Ｂ．そして上から最終行まで、そのテーブルと比較しテーブルにあれば、その行を削除し、重複件数を＋１する。
Ｃ．テーブルに無ければ、テーブルにキーを加え、
その行は残し、重複カウント数は１にする。
（３）直接i行のキーに注目しi＋１から最終行まで
　　同じものがないか調べ、あれば削除し、重複件数を
　　＋１する（＃１のご回答はこれ）
（４）構造を持ちこむ方法
テーブル法は、テーブルにあるキーを総なめで聞きます（それで時間がかかる）がそれを避けるためヒープ（２分木）やＢツリーやその他でキーを持つ方法もあります。データ構造に興味が無く、数千行以下であれば、考えることもないかと思いますがあることはあります。ハッシュ法とかも。ＡＢに付いてコードが必要なら載せます。

回答No.1

nishi6

1行目は表題で、A1から追番、項目１、項目2、項目3、項目4、100、200、300、400 が並んでいるとします。

なぜ"200"項目に書くのかとフラグ１の意味がよく分かりませんが、
一致する行があった場合、"200"項目に一致した回数を書くようにしてみました。
3行が一致していれば、照合回数は1行目と2行目、1行目と3行目の2回で、2を書き込んでいます。
一致した時点で、下にある行のA列には『削除』を書き込んでいるので、2行目と3行目の比較はしないようにしてあります。

シートのコードウインドウに貼り付けます。

Sub DataCheck()
　　Dim rg As Range 'セル
　　Dim rw1 As Long, rw2 As Long '行カウンタ
　　Dim rwMax As Long '最終行
　　Dim chk As Integer '同一かどうかチェックする
　　Dim SameCot As Long '同一行の数

　　rwMax = Range("A1").End(xlDown).Row - 1

　　With Range("A1")
　　　　For rw1 = 1 To rwMax - 1
　　　　　　SameCot = 0
　　　　　　If .Offset(rw1, 0) <> "削除" Then
　　　　　　　　'行単位で比較する
　　　　　　　　For rw2 = rw1 + 1 To rwMax
　　　　　　　　　　chk = 0
　　　　　　　　　　If .Offset(rw1, 1) = .Offset(rw2, 1) Then chk = chk + 1
　　　　　　　　　　If .Offset(rw1, 2) = .Offset(rw2, 2) Then chk = chk + 1
　　　　　　　　　　If .Offset(rw1, 3) = .Offset(rw2, 3) Then chk = chk + 1
　　　　　　　　　　If .Offset(rw1, 4) = .Offset(rw2, 4) Then chk = chk + 1
　　　　　　　　　　'全て同じだったら
　　　　　　　　　　If chk = 4 Then
　　　　　　　　　　　　.Offset(rw2, 0) = "削除" 'A列に『削除』の印を付ける
　　　　　　　　　　　　SameCot = SameCot + 1
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　　　If SameCot > 0 Then .Offset(rw1, 6) = .Offset(rw1, 6) + SameCot
　　　　Next

　　　　'『削除』マークを付けた行を削除する
　　　　For rw1 = rwMax To 1 Step -1
　　　　　　If .Offset(rw1, 0) = "削除" Then
　　　　　　　　.Offset(rw1, 0).Select: Selection.EntireRow.Delete
　　　　　　End If
　　　　Next
　　　　.Offset(0, 0).Select
　　End With
End Sub

Private Sub CommandButton1_Click()
　　DataCheck
End Sub