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.13

kkkkkm

> 最後の案を消す範囲が分かりにくいです。最後の案、から、Set Fr = nothingを含めて削除すればよろしいでしょうか？

はいそうです。

お礼

Kkkkkm さん。動きました。まさにこの形なんですが、特殊カウントでの私の説明足らずで
理想から少ーし離れてたのと、もう１つ説明足らずが有りました。
まずは特殊カウントの補足になります。
範囲(D6:G8)の3×4の１範囲 にK10の値と同値が黄色くなり、上下斜めに重複した値を1個ととし、水平上の重複はカウント無しとする。
と、してたのですが、ここを、上手斜めで１マス２マス空いても1個、としたかったのです。必ずしも連なったものだけのカウントではなく、ここで例になりますが、D6とG8 が黄色くなっても1個としたかったのです。続いての例えなんですが、D6 とD8が重複しても1個としたかったのです。ここまでが特殊カウントの補足です。
もう１つは、
最初の説明文から引き抜いての説明になります。
…併せて、範囲(AA11:AJ11)の合計数値が3個以上のア～コの記号はその行数の(M11:R11)に、２個だけの記号はその行数の(S11:X11)にと、左りから入れる形にして、特殊カウントがされる度に併せて、下から下にと、反映する形を希望します。
とありまして、範囲(AA11:AJ11)が満たされると次は範囲(AA12:AJ12)へと移りますが、これと同時に範囲(M11:R11 )と範囲(S11 :X11 )も１つ下の行へと移行して12行目分の計算結果を出したいのです。
そうなるとソースも根本からやっぱり変わって来ますよね。

回答No.12

kkkkkm

「コンパイル エラーで修正候補ステートメメントの最後」の理由は、以下のサイトの概要で確認してください。

修正候補: ステートメントの最後
http://officetanaka.net/excel/vba/error/compilation_error/error_2.htm
VBAのエラー
http://officetanaka.net/excel/vba/error/
これの構文エラーに該当すると思います。

上記の理由ですので、エラーになっていないこちらではその原因がわからないということになります。

お礼

こんばんは、kkkkkm さん。理想的な方向に仕上がってるんですが、特殊カウントが正解してる箇所と間違ってる箇所があるんです。
あと、バグって言う方が正しいんですかはわからないんですけど、数字記号で試してて、K10の値が数字記号の6(断定はしませんが)の時、D11やE11が同値の場合、色の塗りつぶしがそのままで消えずに残ってることがあります。
どうしてでしょうか？バグと言うのにふさわしいですか？初めての経験です。

回答No.11

HohoPapa

>それと併せて
上記以降も解釈して組み込んでみました。

なお、深く考えていませんが、
>合計数値が3個以上
これと、
>２個だけの記号
これが6個を超えることはないんでしょうか。

また、
>特殊カウントがされる度に併せて、下から下にと
この記述がよくわかりません。

Sub sample1()

　Dim ChkRng1 As Range
　Dim ChkRng2 As Range
　Dim ChkRng3 As Range
　Dim ChkRng4 As Range
　Dim ChkRng5 As Range
　Dim Cnt3Rng As Range
　Dim Cnt2Rng As Range
　Dim AnsRng As Range
　Dim ColCnt As Long
　Dim HitCnt As Long
　Dim i As Long
　Dim j As Long

　With ThisWorkbook.Sheets(1)

　　Set ChkRng1 = Range(.Cells(6, 4), .Cells(8, 7))
　　Set ChkRng2 = Range(.Cells(9, 4), .Cells(11, 7))
　　Set ChkRng3 = Range(.Cells(12, 4), .Cells(14, 7))
　　Set ChkRng4 = Range(.Cells(15, 4), .Cells(17, 7))
　　Set ChkRng5 = Range(.Cells(18, 4), .Cells(20, 7))
　　Set Cnt3Rng = Range(.Cells(11, 13), .Cells(11, 18))
　　Set Cnt2Rng = Range(.Cells(11, 19), .Cells(11, 24))
　　Set AnsRng = Range(.Cells(10, 27), .Cells(11, 36))

　　For ColCnt = 1 To 10
　　　.Cells(10, 11).Value = AnsRng(1, ColCnt).Value
　　　AnsRng(2, ColCnt).Value = ""

　　　HitCnt = 0
　　　If isHit(ChkRng1, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng2, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng3, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng4, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng5, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　AnsRng(2, ColCnt).Value = HitCnt
　　Next ColCnt

　　i = 0
　　j = 0
　　For ColCnt = 1 To 10
　　　If AnsRng(2, ColCnt).Value >= 3 Then
　　　　i = i + 1
　　　　Cnt3Rng(1, i) = AnsRng(1, ColCnt).Value
　　　End If
　　　If AnsRng(2, ColCnt).Value = 2 Then
　　　　j = j + 1
　　　　Cnt2Rng(1, j) = AnsRng(1, ColCnt).Value
　　　End If
　　Next ColCnt

　End With

End Sub

'//-------------ヒット判定関数
Function isHit(MyRange As Range, MyData As Variant) As Boolean

　Dim ColNum As Long
　isHit = False
　With MyRange(2, 1)
　　If (.Value = MyData) And _
　　　 ((.Offset(-1, 0).Value = MyData) Or _
　　　 (.Offset(-1, 1).Value = MyData) Or _
　　　 (.Offset(1, 0).Value = MyData) Or _
　　　 (.Offset(1, 1).Value = MyData)) Then
　　　isHit = True
　　　Exit Function
　　End If
　End With

　For ColNum = 2 To 3
　　With MyRange(2, ColNum)
　　　If (.Value = MyData) And _
　　　　 ((.Offset(-1, -1).Value = MyData) Or _
　　　　 (.Offset(-1, 0).Value = MyData) Or _
　　　　 (.Offset(-1, 1).Value = MyData) Or _
　　　　 (.Offset(1, -1).Value = MyData) Or _
　　　　 (.Offset(1, 0).Value = MyData) Or _
　　　　 (.Offset(1, 1).Value = MyData)) Then
　　　　isHit = True
　　　　Exit Function
　　　End If
　　End With
　Next ColNum

　With MyRange(2, 4)
　　If (.Value = MyData) And _
　　　 ((.Offset(-1, -1).Value = MyData) Or _
　　　 (.Offset(-1, 0).Value = MyData) Or _
　　　 (.Offset(1, -1).Value = MyData) Or _
　　　 (.Offset(1, 0).Value = MyData)) Then
　　　isHit = True
　　　Exit Function
　　End If
　End With

End Function

回答No.10

HohoPapa

>(AA11:AJ11)に、0無し(0入りでもOK)で入れたいです
この部分までは、期待する動作が私なりに理解できたので
コードにしてみました。

このが期待通りなら、
>それと併せて．．
これ以降の説明を改めてしてみてください。

Sub sample1()

　Dim ChkRng1 As Range
　Dim ChkRng2 As Range
　Dim ChkRng3 As Range
　Dim ChkRng4 As Range
　Dim ChkRng5 As Range
　Dim AnsRng As Range
　Dim ColCnt As Long
　Dim HitCnt As Long

　With ThisWorkbook.Sheets(1)

　　Set ChkRng1 = Range(.Cells(6, 4), .Cells(8, 7))
　　Set ChkRng2 = Range(.Cells(9, 4), .Cells(11, 7))
　　Set ChkRng3 = Range(.Cells(12, 4), .Cells(14, 7))
　　Set ChkRng4 = Range(.Cells(15, 4), .Cells(17, 7))
　　Set ChkRng5 = Range(.Cells(18, 4), .Cells(20, 7))
　　Set AnsRng = Range(.Cells(10, 27), .Cells(11, 36))

　　For ColCnt = 1 To 10
　　　.Cells(10, 11).Value = AnsRng(1, ColCnt).Value
　　　AnsRng(2, ColCnt).Value = ""

　　　HitCnt = 0
　　　If isHit(ChkRng1, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng2, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng3, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng4, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　If isHit(ChkRng5, AnsRng(1, ColCnt).Value) = True Then
　　　　HitCnt = HitCnt + 1
　　　End If
　　　AnsRng(2, ColCnt).Value = HitCnt
　　Next ColCnt

　End With

End Sub

'//-------------ヒット判定関数
Function isHit(MyRange As Range, MyData As Variant) As Boolean

　Dim ColNum As Long
　isHit = False
　With MyRange(2, 1)
　　If (.Value = MyData) And _
　　　 ((.Offset(-1, 0).Value = MyData) Or _
　　　 (.Offset(-1, 1).Value = MyData) Or _
　　　 (.Offset(1, 0).Value = MyData) Or _
　　　 (.Offset(1, 1).Value = MyData)) Then
　　　isHit = True
　　　Exit Function
　　End If
　End With

　For ColNum = 2 To 3
　　With MyRange(2, ColNum)
　　　If (.Value = MyData) And _
　　　　 ((.Offset(-1, -1).Value = MyData) Or _
　　　　 (.Offset(-1, 0).Value = MyData) Or _
　　　　 (.Offset(-1, 1).Value = MyData) Or _
　　　　 (.Offset(1, -1).Value = MyData) Or _
　　　　 (.Offset(1, 0).Value = MyData) Or _
　　　　 (.Offset(1, 1).Value = MyData)) Then
　　　　isHit = True
　　　　Exit Function
　　　End If
　　End With
　Next ColNum

　With MyRange(2, 4)
　　If (.Value = MyData) And _
　　　 ((.Offset(-1, -1).Value = MyData) Or _
　　　 (.Offset(-1, 0).Value = MyData) Or _
　　　 (.Offset(1, -1).Value = MyData) Or _
　　　 (.Offset(1, 0).Value = MyData)) Then
　　　isHit = True
　　　Exit Function
　　End If
　End With

End Function

お礼

返事おくれましたHoho Papaさん。お久しぶりです。いつもありがとうございます。只今試してみました。私の初歩的な理解不足で引っ掛かったところがありまして、お聞きしたいです。
with this workbook .sheets(1)
の箇所に自分の使いたい場所のsheet 2(2)をいれても上手くいきません。何が原因ですかね？

回答No.9

kkkkkm

> ElseIf c.Row = i + 2 Then
> でコンパイル エラーで修正候補ステートメメントの最後となりThenを指摘してます。
> どうしたらよろしいですか？

こちらではそのようにならないので、そちらで確認するしか方法はないと思います。

お礼

こんにちはkkkkkm さん。お時間をお取りいただいていつもありがとうございます。前に書いて作って頂いたソース(もしくはのA案、B案、最後の案)についての削除範囲に混乱してましてお聞きしたいです。
最後の案を消す範囲が分かりにくいです。最後の案、から、Set Fr = nothingを含めて削除すればよろしいでしょうか？

回答No.8

kkkkkm

> コを9にして0をアにすれば

数値にしたい場合、最初の案ではちゃんと動かないと思います。
それ以外の案だとなんでもありなので(AA10からAJ10のデータを順に表示するだけなので初期にK10もしくはK9に正しいデータを入れていれば)で試してみてください。

「もしくはのA案」なら何もしなくてそのまま実行したらK9に連携用(AA10からAJ10のデータを順に表示するための数値)のデータが勝手に入るのでなんでもありです。

お礼

kkkkkm さん。こんばんは。問題がでました。
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
の所の
ElseIf c.Row = i + 2 Then
でコンパイル エラーで修正候補ステートメメントの最後となりThenを指摘してます。
どうしたらよろしいですか？

回答No.7

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

''最初の案
'If Range("K10").Value = "コ" Then
' Range("K10").Value = "ア"
'ElseIf Range("K10").Value = "オ" Then
' Range("K10").Value = ChrW(AscW(Range("K10").Value) + 1)
'Else
' Range("K10").Value = ChrW(AscW(Range("K10").Value) + 2)
'End If

''もしくはのA案とB案
'If Range("K9").Value = 9 Then
' Range("K9").Value = 0
'Else
' Range("K9").Value = Range("K9").Value + 1
'End If
''B案は↓が不要
'Range("K10").Value = Range("AA10").Offset(0, Range("K9").Value).Value

'最後の案
Set Fr = Range("AA10:AJ10").Find(What:=Range("K10").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not Fr Is Nothing Then
If Fr.Address = Range("AJ10").Address Then
Range("K10").Value = Range("AA10").Value
Else
Range("K10").Value = Fr.Offset(0, 1).Value
End If
Else
MsgBox Range("K10").Value & "が見つかりません"
End If
Set Fr = Nothing

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 < 11 Then
LastRow = 11
End If
mCount = 6 - WorksheetFunction.CountBlank(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 And c.Row <> d.Row Then
If c.Value = d.Value Then
mSearch = 1
Exit Function
End If
End If
Next
mSearch = 0
End Function

お礼

ありがとうございます。K10 にア～コではなく数値の0～9を入れることになっても、コを9にして0をアにすれば大丈夫ですかね？

回答No.6

kkkkkm

あとこれもありかも

K10にアとか入れておいて(AA10からAJ10のデータを順に表示)

Set Fr = Range("AA10:AJ10").Find(What:=Range("K10").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not Fr Is Nothing Then
If Fr.Address = Range("AJ10").Address Then
Range("K10").Value = Range("AA10").Value
Else
Range("K10").Value = Fr.Offset(0, 1).Value
End If
Else
MsgBox Range("K10").Value & "が見つかりません"
End If
Set Fr = Nothing

お礼

すみません。訂正も含めたソースを書いてもらうわけにはいかないでしょうか？多分、ちょっとだけ混乱気味ですw
感謝と同時に凄く申し訳ない気持ちもいっぱいです。(^_^ゞ

回答No.5

kkkkkm

> K10へ自動的にア～コが１つずつ順に入る動作

SumCount = 0の前に

If Range("K10").Value = "コ" Then
Range("K10").Value = "ア"
ElseIf Range("K10").Value = "オ" Then
Range("K10").Value = ChrW(AscW(Range("K10").Value) + 1)
Else
Range("K10").Value = ChrW(AscW(Range("K10").Value) + 2)
End If

もしくは
K9に0を入れておいて(AA10からJ10のデータを順に表示なのでAA10からの文字を変更してもこのままで良い)
もしくはのA案
If Range("K9").Value = 9 Then
Range("K9").Value = 0
Else
Range("K9").Value = Range("K9").Value + 1
End If
Range("K10").Value = Range("AA10").Offset(0, Range("K9").Value).Value

もしくはのB案
K10に
=OFFSET(AA10,0,K9)
として
If Range("K9").Value = 9 Then
Range("K9").Value = 0
Else
Range("K9").Value = Range("K9").Value + 1
End If

ランダムに出したい場合はK10に
=CHOOSE(RANDBETWEEN(1,10),"ア","イ","ウ","エ","オ","カ","キ","ク","ケ","コ")

回答No.4

kkkkkm

訂正その3

文字入れるの面倒だったので数値でテストしてたからCountにしてたけど文字だからCountAでした。どちらでもいいように以下のように変更してください。

mCount = WorksheetFunction.Count(Range(Cells(LastRow, mColumn), Cells(LastRow, mColumn).Offset(0, 5)))

を

mCount = 6 - WorksheetFunction.CountBlank(Range(Cells(LastRow, mColumn), Cells(LastRow, mColumn).Offset(0, 5)))

お礼

お久しぶりです、kkkkkmさん。いつもありがとうございます。この作っていただいたソースに、K10へ自動的にア～コが１つずつ順に入る動作を付け加えるとどのようなソースになりますか？