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

HohoPapa

>私の初歩的な理解不足で引っ掛かったところがありまして、お聞きしたいです。
>with this workbook .sheets(1)
>の箇所に自分の使いたい場所のsheet 2(2)をいれても上手くいきません。
>何が原因ですかね？

　With ThisWorkbook.Sheets(1)
を2枚目のシートにするのであれば
　With ThisWorkbook.Sheets(2)
とします。

お礼

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

回答No.22

kkkkkm

SumCount = 0
以降次のEnd Subまでは以下に変更

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 = i: oRow2 = i + 2
oColumn1 = Columns("D:D").Column: oColumn2 = Columns("G:G").Column
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
mRow = Cells(Rows.Count, Fr.Column).End(xlUp).Offset(1, 0).Row
Cells(mRow, Fr.Column).Value = SumCount
Else
MsgBox sData & "が見つかりません"
End If
If SumCount = 2 Then
Call mSet(Range("S:S").Column, sData, mRow)
ElseIf SumCount > 2 Then
Call mSet(Range("M:M").Column, sData, mRow)
End If
End Sub

お礼

Kkkkkm さ～んヒソヒソ！何処を…どうすれば…よろしいですか～？ヒソヒソ( ´ノД｀)

回答No.21

kkkkkm

これでいいんじゃないでしょうか。案はどれを選んでいるのか不明なので全て記載しています。A案が有効な状態だと思う(かなり忘れてるので)

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
Dim mRow As Long

''最初の案
'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 = -2: oRow2 = 2
oColumn1 = -3: oColumn2 = 3
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
mRow = Cells(Rows.Count, Fr.Column).End(xlUp).Offset(1, 0).Row
Cells(mRow, Fr.Column).Value = SumCount
Else
MsgBox sData & "が見つかりません"
End If
If SumCount = 2 Then
Call mSet(Range("S:S").Column, sData, mRow)
ElseIf SumCount > 2 Then
Call mSet(Range("M:M").Column, sData, mRow)
End If
End Sub

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

mCount = 6 - WorksheetFunction.CountBlank(Range(Cells(mRow, mColumn), Cells(mRow, mColumn).Offset(0, 5)))
Cells(mRow, mColumn).Offset(0, mCount).Value = mData
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

お礼

こんばんはkkkkkm さん。今、パソコンにファイル転送して(転送初めてで凄く便利でした。)実行してみましたがカウントがしっかりとされてませんでした。
合計値が全部0になるだけでした。

回答No.20

kkkkkm

> そういう場合は空白でも大丈夫です。
と
> 空白になる場合はそのままで、何も入れません。
2個もしくは3個以上ではない場合、空白のセルを(M11:R11)もしくは(S11:X11)の間に都度存在させる(空白を存在させるとどれくらいのスパンで2個もしくは3個以上が出現したのかイメージとしてとらえやすい)というのではなく、(M11:R11)もしくは(S11:X11)ではスルーする(出たときだけ記載する)という事ですか

また、2個もしくは3個以上が10回のうち7回以上出るという事は考えないのですか

お礼

いつも順序立て前の補助回答ありがとうございます。
スルーする、でも、空白を入れる、でも大丈夫ですのでお願いします。

後、してきた流れで7個以上入るとは考えてません。
大体な流れです。宜しくお願い致します。

回答No.19

kkkkkm

> 「合計数値が3個以上のア～コの記号はその行数の(M11:R11)に、合計値が２個だけの記号はその行数の(S11:X11)に、全て左詰めで１行完結すれば下にへ」の件がまだ解決しきれてなかったんです。

10回実行したら10列必要です。7回目に指定列より右にはみ出します。

お礼

10 回実行したら(10 回実行されながらでも大丈夫です。)、範囲(AA10:AJ10)に左から順にア～コと付ってますのでその下の範囲(AA11:AJ11)にア～コの合計値が出て、
その合計値が分別されます。

次の10 回実行は12 行目に行くのですが分別される合計値も12 行目にいきます(空白も出ますすが無視)。

特殊カウントの件ですが、そうですね、行上の重複以外はカウントと言うことになりますね。ですがカウントできる条件が複数個有ったとしても1個になります。

複雑だとは思いますがお願い致します。

回答No.18

kkkkkm

oRow1 = -2: oRow2 = 2
oColumn1 = -3: oColumn2 = 3

です。いい加減飽きてきました。

お礼

ご回答ありがとうございます。
「合計数値が3個以上のア～コの記号はその行数の(M11:R11)に、合計値が２個だけの記号はその行数の(S11:X11)に、全て左詰めで１行完結すれば下にへ」の件がまだ解決しきれてなかったんです。
どのようにすればよろしいですか？

回答No.17

kkkkkm

> 10回分で1行なら2個3個が6列では不足です。」の疑問に対して、
> 足りる事情があるんです。

その事情とは？10回実行したら10列必要です。

> 先程言いました5 範囲の内の１範囲内に２行分が黄色く平行線状態になった場合になります。

そんな事を聞いていません。G7？なのですよ。E6とG7の関係はどうなるのかという事です(E6が変わっても上下左右でそれと同じ位置関係のセルも)

結局行方向以外は全てカウント対象ということですか？
だとしたら

oRow1 = -3: oRow2 = 3
oColumn1 = -3: oColumn2 = 3

お礼

あっ、すみません。こっちの回答を見れてませんでした。
ア～コがK10 に一回一回順に入ります。
(11行目の流れです。)
これをマクロで10回することがア～コを全部入れる、という１つの形となります。
次に合計値から判断されたア～コが(M11:R11)、(S11:X11)にと、どちらも左詰めに分別されます。
空白になる場合はそのままで、何も入れません。
(12 行目に移ります)
11 行目でしたことと同じながれになりまして、13行目にと、ずっと同じ流れになります。

今回は的が外れてませんか心配です。

回答No.16

kkkkkm

> マクロで10回分したら満たされると思ってます。(^_^ゞマクロでの10 回分をまとまった１回分とします。そして次の行に行きたいです。

現状そうなっていますが

> 5範囲には新しく別の値がはいりますので

意味が分かりません。急に5範囲とか。

> そういう場合は空白

10回分で1行なら2個3個が6列では不足です。

> の状態に加えD8、E8、F8、G8が黄色くなっても１個とします。

G7？

お礼

こんにちはkkkkkm さん。私の諸事情とは言え大分時間を開け、事を混乱させてしまいましたね。ヘルプして頂いてるのに申し訳ないです。と共にいつもありがとうございます。
では、早速、解答していきます。
>>「5範囲には新しく別の値がはいりますので

意味が分かりません。急に5範囲とか。」
の疑問に対して、

(D6 :G20)を3×4ます区切りで 5等分してありまして、それら１マスずつにランダムに記号が入ります。

>>「 そういう場合は空白

10回分で1行なら2個3個が6列では不足です。」の疑問に対して、
足りる事情があるんです。

>>「 の状態に加えD8、E8、F8、G8が黄色くなっても１個とします。」の疑問に対して、

これは特殊カウントを理解して頂くための例えでありまして説明させて下さい。
先程言いました5 範囲の内の１範囲内に２行分が黄色く平行線状態になった場合になります。その２本の間は色無し一本状態です。それでも1個とカウントです。
(連結されても、されていなくても良い上下斜め)と言う内容が含まれる事を分かって頂く手段の１つでした。
最初の私の説明不足からなりました。
連結されてる上下斜めはカウントしてましたので、そこで自分の説明不足に気がつきました。すみませんと同時に再びお願いしたいです。_(..)_

回答No.15

kkkkkm

> それです。一回実行すれば次の行へ移行、で間違いないです。

でしたら何故

> 3個以上のア～コの記号はその行数の(M11:R11)に、２個だけの記号はその行数の(S11:X11)にと、左りから入れる形にして

6列必要なのですか？　左から入れるとはどういう意味ですか？

> 範囲(AA11:AJ11)が満たされる

満たされるとはどういう意味ですか？　一回の実行では一個の文字(数値)だけカウントすると思いますが、そうでしたら満たされることはありえません。

また、AA11:AJ11は一回に一行消費しますが、M11:R11及びS11:X11は無い場合があるので必ず消費するとは限りません。どうしますか？

すべてのパターンにたいして具体例で回答してください。

先の「たとえばE6とD8の関係が一致と考えるのでしたら」について何も答えがありませんが、それも含めて全ての疑問が解決しなければ先はありません。

お礼

>> 「それです。一回実行すれば次の行へ移行、で間違いないです。

でしたら何故

> 3個以上のア～コの記号はその行数の(M11:R11)に、２個だけの記号はその行数の(S11:X11)にと、左りから入れる形にして

6列必要なのですか？　左から入れるとはどういう意味ですか？」の疑問に対しては、
6列にしたいのは視覚的に見易くしたいのと念のために開けておくとおかしな事にはならないだろうと主観的思考から余裕を作って置くべきと予想しました。
左から、の疑問に対しては、これも左詰めにすると視覚的に見易いと思いました。

>> 「範囲(AA11:AJ11)が満たされる

満たされるとはどういう意味ですか？　一回の実行では一個の文字(数値)だけカウントすると思いますが、そうでしたら満たされることはありえません。」の疑問に対して、
マクロで10回分したら満たされると思ってます。(^_^ゞマクロでの10 回分をまとまった１回分とします。そして次の行に行きたいです。5範囲には新しく別の値がはいりますので。
>>「また、AA11:AJ11は一回に一行消費しますが、M11:R11及びS11:X11は無い場合があるので必ず消費するとは限りません。どうしますか？」の疑問に対して、
本当にそうですよね！Σ（￣□￣;）そういう場合があることを想定にいれてませんでした。そういう場合は空白でも大丈夫です。

すべてのパターンにたいして具体例で回答してください。

>>先の「たとえばE6とD8の関係が一致と考えるのでしたら」について何も答えがありませんが、それも含めて全ての疑問が解決しなければ先はありません。 この疑問に対して、
E6とD8が黄色くなってるのならこれも１つとして数えます。水平上の重複D6、E6、F6、G6が黄色くても0 です。この状態に加えD8、E8、F8、G8が黄色くなっても１個とします。

物事には順序があり、順序とする前の何かを的確に示さなければ順序立てもできませんね。ご指摘感謝します。

回答No.14

kkkkkm

> 上手斜めで１マス２マス空いても1個、

たとえばE6とD8の関係が一致と考えるのでしたら

oRow1 = -2: oRow2 = 2
oColumn1 = -2: oColumn2 = 2

> 範囲(AA11:AJ11)が満たされると次は範囲(AA12:AJ12)へと移りますが、これと同時に範囲(M11:R11 )と範囲(S11 :X11 )も１つ下の行へと移行して12行目分の計算結果を出したいのです。

一回実行にたいして一行と考えるということですか。

お礼

それです。一回実行すれば次の行へ移行、で間違いないです。
分かって貰えるのって気持ちが良いですね。