Excel2007で特殊なカウントをしたいのですが

質問

久々お世話になります。
Excel2007で特殊なカウントがしたいのですができません。そこでご助力頂ければ幸いです。内容は以下に説明します。

範囲D6 : G8 の3×4の１マスずつにアイウエオカキクケコのいずれかがランダムに入ります。
この3×4を１範囲とし、(D6 :G20)に合計5範囲あります。
他の4範囲(D9:G11)、(D12:G14)、(D15:G17)、(D18:G20)も上の様となります。

次に、K10にア～コを１つずつ順に入れると入れた値に応じて範囲D6 : G20 にある同値が黄色く塗りつぶされるという形になっています。
ここからが私にとって特殊カウントであり難題になります。

K10の値に応じて黄色くなった値を特殊な形でカウントします。

そのルールはこうなります。

K10の値に応じて、3×4の１範囲内に、上下と斜めで重複したものを1個と捉え、水平に重複しても1個と捉えない。
そして、例え３行内に、上下斜めに重複する形が複数確認できたとしたも1個としてカウントします。
5範囲ありますので最大合計値は5個になります。最小合計値は0ですが、空白(空白でなくてもOK )にします。

次に、その合計値を、範囲(AA10:AJ10)に左から順にア～コと付ってますのでその下の範囲(AA11:AJ11)に、0無し(0入りでもOK)で入れたいです。新しく特殊カウントされるとその下の行へ下の行へと合計値が射出される形を希望します。
それと併せて、範囲(AA11:AJ11)の合計数値が3個以上のア～コの記号はその行数の(M11:R11)に、２個だけの記号はその行数の(S11:X11)にと、左りから入れる形にして、特殊カウントがされる度に併せて、下から下にと、反映する形を希望します。

ご協力お願い致します。

回答No.24

kkkkkm · ベストアンサー

> 実行してみましたがカウントがしっかりとされてませんでした。

それはセルの位置とか設定が違うのでしょう。
いまさらそんなことを言っても仕方がないですね。

お礼

そうなんですよw
下の方をカウントしてるみたいで、目的の所とは違う場所をカウントしてるようです。
今頑張ってソースをみなおしてます。(D6 : G20 )をカウントのフォーカスに定めるには何処から見直しが必要ですか？

回答No.3

kkkkkm

訂正その2
> 水平に重複しても1個と捉えない

を忘れてました。

If c.Address <> d.Address Then

を

If c.Address <> d.Address And c.Row <> d.Row Then

に変更してください。

回答No.2

kkkkkm

訂正

If LastRow = 10 Then
LastRow = 11
End If

を

If LastRow < 11 Then
LastRow = 11
End If

にしてください。

回答No.1

kkkkkm

深く考えてませんが、これでどうにかなると思います。

Sub Test()
Dim c As Range, Fr As Range
Dim i As Long, mCount As Integer, SumCount As Integer
Dim oRow1 As Long, oRow2 As Long, oColumn1 As Long, oColumn2 As Long
Dim sData As Variant

SumCount = 0
sData = Range("K10").Value
For i = 6 To 18 Step 3
For Each c In Range(Cells(i, "D"), Cells(i + 2, "G"))
If c.Value = sData Then
oRow1 = -1: oRow2 = 1
oColumn1 = -1: oColumn2 = 1
If c.Row = i Then
oRow1 = 0
ElseIf c.Row = i + 2 Then
oRow2 = 0
End If
If c.Column = Range("D:D").Column Then
oColumn1 = 0
ElseIf c.Column = Range("G:G").Column Then
oColumn2 = 0
End If
mCount = mSearch(c, oRow1, oColumn1, oRow2, oColumn2)
If mCount = 1 Then
SumCount = SumCount + mCount
Exit For
End If
End If
Next
Next
Set Fr = Range("AA10:AJ10").Find(What:=sData, LookIn:=xlValues, lookat:=xlWhole)
If Not Fr Is Nothing Then
Cells(Rows.Count, Fr.Column).End(xlUp).Offset(1, 0).Value = SumCount
Else
MsgBox sData & "が見つかりません"
End If
If SumCount = 2 Then
Call mSet(Range("S:S").Column, sData)
ElseIf SumCount > 2 Then
Call mSet(Range("M:M").Column, sData)
End If
End Sub

Function mSet(ByVal mColumn As Long, ByVal mData As Variant)
Dim LastRow As Long
Dim mCount As Integer

LastRow = Cells(Rows.Count, mColumn).End(xlUp).Row
If LastRow = 10 Then
LastRow = 11
End If
mCount = WorksheetFunction.Count(Range(Cells(LastRow, mColumn), Cells(LastRow, mColumn).Offset(0, 5)))
If mCount = 6 Then
Cells(LastRow + 1, mColumn).Value = mData
Else
Cells(LastRow, mColumn).Offset(0, mCount).Value = mData
End If
End Function

Function mSearch(ByRef d As Range, ByVal oRow1 As Long, ByVal oColumn1 As Long, ByVal oRow2 As Long, ByVal oColumn2 As Long) As Integer
Dim c As Range

For Each c In Range(d.Offset(oRow1, oColumn1), d.Offset(oRow2, oColumn2))
If c.Address <> d.Address Then
If c.Value = d.Value Then
mSearch = 1
Exit Function
End If
End If
Next
mSearch = 0
End Function