EXCEL97のマクロ処理について

質問

EXCEL97のマクロ処理について教えてください。
下記のシート例のようなシート（アクセスのクロス集計のようなもの）を最初に複数範囲指定(アクティブ)します。その後にその範囲指定したなかで項目が1～５まで全て同じモノだけを統一して、種類で存在するものも統一させます。一つ目のものに種類１がなくても同一のものに種類1があれば統一後のデータは種類1の列に"1"がつくようにします。ちなみに種類はその時によりどれだけ存在するかわからないのが前提です。削除するデータは回路Noが大きいものを消すようにします。下がそのデータの例です。
===============　エクセルシート例 ===================================
回路No　　項目１　項目２　項目３　項目４　項目５　種類１　種類２　種類３ ...
１　　　　　　AAA　　BBB　　CCC　　　DDD　　EEE　　　１　　　　　　　　１
１　　　　　　FFF　　DDD　　UUU　　　DDD　　OOO　　　　　　　１　　　　１
１　　　　　　UUU　　PPP　　TTT　　　DDD　　EEE　　　１　　　１
２　　　　　　AAA　　BBB　　CCC　　　DDD　　EEE　　　　　　　１　　　　１
２　　　　　　XXX　　QQQ　　SSS　　　NNN　　MMM　　　１　　　１
　　　　　　　　　　　　　　　↓　マクロ処理後
回路No　　項目１　項目２　項目３　項目４　項目５　種類１　種類２　種類３ ...
１　　　　　　AAA　　BBB　　CCC　　　DDD　　EEE　　　１　　　１　　　　１
１　　　　　　FFF　　DDD　　UUU　　　DDD　　OOO　　　　　　　１　　　　１
１　　　　　　UUU　　PPP　　TTT　　　DDD　　EEE　　　１　　　１
２　　　　　　XXX　　QQQ　　SSS　　　NNN　　MMM　　　１　　　１
==================================================================
シート選択後ボタンによりマクロ処理されるように考えています。どうか宜しくお願い致します。

回答No.2

taisuke555 · ベストアンサー

Sub Data_Check()
Dim CRow() As Long

If (TypeName(Selection) = "Range") Then '選択している物がセルならば
With Selection.Areas
'範囲行数取得
For i = 1 To .Count
cnt = cnt + .Item(i).Rows.Count
Next i
'範囲行取得
ReDim CRow(cnt - 1)
cnt = 0
For i = 1 To .Count
With .Item(i)
For j = .Row To .Row + .Rows.Count - 1
CRow(cnt) = j
cnt = cnt + 1
Next j
End With
Next i
End With
'重複チェック
For i = 0 To UBound(CRow)
If (Cells(CRow(i), 1) <> "削除") Then 'Aセルが"削除"以外
For j = i + 1 To UBound(CRow)
If (CRow(i) <> CRow(j)) Then '同一行以外
'B,C,D,E,F列が同じ
If (Cells(CRow(i), 2) = Cells(CRow(j), 2) And _
Cells(CRow(i), 3) = Cells(CRow(j), 3) And _
Cells(CRow(i), 4) = Cells(CRow(j), 4) And _
Cells(CRow(i), 5) = Cells(CRow(j), 5) And _
Cells(CRow(i), 6) = Cells(CRow(j), 6)) Then
If (Cells(CRow(i), 1) < Cells(CRow(j), 1)) Then
WRow = CRow(i) '残す行
DRow = CRow(j) '削除する行
Else
WRow = CRow(j) '残す行
DRow = CRow(i) '削除する行
End If
'G列～最終列まで（種類チェック）
For k = 7 To Cells(1, Columns.Count).End(xlToLeft).Column
If (Cells(CRow(i), k) = 1 Or Cells(CRow(j), k) = 1) Then
Cells(WRow, k) = 1
End If
Next k
'A列に"削除"を記入
Cells(DRow, 1) = "削除"
End If
End If
Next j
End If
Next i
'Aセルに"削除"と入っている行を削除
cnt = 0
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If (Cells(i, 1) = "削除") Then
Rows(i).Delete
cnt = cnt + 1
End If
Next i
MsgBox "選択範囲[ " & Selection.Address(False, False) & " ]には" & Chr(13) & _
CStr(cnt) & "個の重複データがあり、削除しました"
Else
MsgBox "セルを選択してください"
End If
End Sub

お礼

お礼が大変遅れまして申し訳ありません。
処理はまさに完璧でした。
ありがとうございました。

処理を解析して、これを参考にして、現在違うプログラムを開発しています。
本当にありがとうございました

回答No.3

kazuhiko5681

こんにちは。＃１です。マクロに記述ミスがありました。申し訳ございません。修正マクロを作成しました。こちらを参考にしてみて下さい。
＞一つ目のものに種類１がなくても同一のものに種類1があれば統一後のデータは種類1の列に"1"がつくようにします。
まだ、この点につきましては考えておりません。詳細をお知らせ下さい。

Sub test()

Dim myRow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim myCnt As Integer
Dim myCell As Integer

myRow = Range(Selection.Address).Rows.Count
For i = 1 To myRow - 1
If Cells(i, 2).Value = "" Then Exit For
If i = 1 Then myCell = myRow
For j = i + 1 To myCell
For k = 2 To 6
If Cells(i, k).Value = Cells(j, k).Value Then
myCnt = myCnt + 1
If myCnt = 5 Then
Rows(j & ":" & j).ClearContents
End If
End If

Next k
myCnt = 0

Next j
myCell = Cells(myRow, 2).End(xlUp).Row
Next i

Do Until Cells(1, 2).End(xlDown).Row = Cells(Rows.Count, 2).End(xlUp).Row
If Cells(1, 2).End(xlDown).Offset(-1, 0).Value = "" Then
Cells(1, 2).End(xlDown).Offset(-1, 0).EntireRow.Delete Shift:=xlShiftUp
Else
Cells(1, 2).End(xlDown).Offset(1, 0).EntireRow.Delete Shift:=xlShiftUp
End If
Loop

End Sub

お手数をおかけいたします。よろしくお願いいたします。

お礼

お礼が大変遅れまして申し訳ありません。
ありがとうございました。

またなにかありましたら宜しくお願い致します。

回答No.1

kazuhiko5681

初めまして。サンプルマクロを作ってみました。参考にしてみて下さい。
もし不都合なことがありましたら、お知らせ下さい。

Sub test()

Dim myRow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim myCnt As Integer
Dim myCell As Integer

myRow = Range(Selection.Address).Rows.Count
For i = 1 To myRow - 1
If Cells(i, 2).Value = "" Then Exit For
If i = 1 Then myCell = myRow
For j = i + 1 To myCell
For k = 2 To 6
If Cells(i, k).Value = Cells(j, k).Value Then
myCnt = myCnt + 1
If myCnt = 5 Then
Rows(j & ":" & j).ClearContents
End If
End If

Next k
myCnt = 0

Next j
myCell = Cells(myRow, 2).End(xlUp).Row
Next i

For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
' MsgBox Cells(i, 2).Address
If Cells(i, 2).Value = "" Then
Rows(i & ":" & i).Delete Shift:=xlShiftUp
End If
Next i

End Sub

後、
＞一つ目のものに種類１がなくても同一のものに種類1があれば統一後のデータは種類1の列に"1"がつくようにします。
この部分の意味がよくわからなかったので、考えておりません。もう少し詳しくお知らせいただければサンプルマクロを作ってみたいと思います。
ご希望の節は、お手数をおかけいたしますが、お知らせ下さい。

補足

丁寧な説明ありがとうございます。
現在、提示していただいたコードで処理を作成している最中です。
また連絡致します