Excel2016 で特殊なカウントをしたいです。

質問

１度同じ質問をしたのですが、上手くいかなかったのでリトライします。
Excel2016で特殊なカウントがしたいのですができません。そこでご助力頂ければ幸いです。内容は以下に説明します。

範囲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個カウントだけです。 )
例え３行内に、上下斜めに重複する形が複数確認できたとしたも1個としてカウントします。

5範囲ありますので最大合計値は5個になります。最小合計値は0ですが、空白(空白でなくてもOK )にします。

次に、その合計値を、範囲(AA10:AJ10)に左から順にア～コと付ってますので、その下の範囲(AA11:AJ11)に、0無し(0入りでもOK)で入れたいです。
範囲(AA11:AJ11)が満杯になると範囲(D6:G20 )に新しくア～コの記号をランダムに入れます。
再び特殊カウントされると範囲(AA11:AJ11)のその下の行へ下の行へと合計値が射出される繰り返しの形を希望します。

それと併せて、範囲(AA11:AJ11)の合計数値が3個以上のア～コの記号はその行数の(M11:R11)に、２個だけの記号はその行数の(S11:X11)にと、左りから入れる形にして、特殊カウントがされる度に上の繰り返しの形と併せて、下から下にと、反映する形を希望します。

ご協力お願い致します。

回答No.13

kkkkkm · ベストアンサー

> 漢字やごちゃごちゃしたのが混ざってました。

こちらから見えないことを言われてもわかりませんし、スマホからパソコンに云々というのも私には関係のない事なのでわかりません。

お礼

バッチリできました。気持ちが良かったです。今度は図も載せられるように工夫してみたいと思います。
ありがとうございました。

回答No.12

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
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 And c.Value <> "" 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 & "が見つかりません"
Exit Sub
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(Cells(oRow1, oColumn1), Cells(oRow2, oColumn2))
If c.Address <> d.Address And c.Row <> d.Row And c.Value <> "" Then
If c.Value = d.Value Then
mSearch = 1
Exit Function
End If
End If
Next
mSearch = 0
End Function

お礼

なんとか頑張ります。まだまだスマホやパソコンの様々に不慣れで…。ソースをアップロードして張り付けるのも全然なれてません。
しかしながらたった今、怪しい事を発見しました。
ソースの張り付け作業に翻弄されてる中、これまで張り付けてきたソースを見返したら、漢字やごちゃごちゃしたのが混ざってました。これって危ないですか？もしかしたらこれのせいでしょうか？

補足

私のスマホが危険なんですかね？

回答No.11

kkkkkm

データの無いセルがあるという事ですね。
No9に追加して

Function mSearch(

の方の

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

を

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

に変更してください。

お礼

すみません。さっきのは間違いでした。今使用してるソースをパソコンからスマホに移動させるのが、不慣れなものでできなくて、頂いたスマホ内の複数のソースから誤って選択してしまいました。もう少しお待ち下さいね。

回答No.10

kkkkkm

> あの、本当にお手数をお掛けするんですが、もう一度全てのコードを書いて頂けませんでしょうか？

逆でしょう。あなたの実行しているコードとカウントがおかしいデータを示すのが筋です。
データは、以下のようにコンマ区切りで。
0,1,5,4
5,4,8,6
2,5,0,8

お礼

本当にそうでした。これを先に見せるべきですね。
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

''もしくはの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

' 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 = 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

回答No.9

kkkkkm

5ブロックのセルは全てデータで埋まっているという設定だと思いましたが、データの無いセルがあるのでしたら

If c.Value = sData Then

を

If c.Value = sData And c.Value <> "" Then

に変更してください。

お礼

おはようございます。いつも本当にありがとうございます。
今回のこれをしてみたところ変わりがありませんでした。
あの、本当にお手数をお掛けするんですが、もう一度全てのコードを書いて頂けませんでしょうか？
後、マクロのセキュリティとかは関係有るんでしょうか？

回答No.8

kkkkkm

> ア～コを0～9に変えてしてみたんですが0だけ必ずカウントミスしてます。

こちらではミスが出ないので、どのようにデータが配置されているのか不明な為に確かめようがありません。

お礼

おまたせしました。これが今使用させて頂いてるソースになります。
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

補足

もしくはのA案を使用してます。

回答No.7

kkkkkm

> O列に罫線が加算されたりされなかったり。マクロボタンの連打に対応しきれなかったりする場合ってありますか？

何も設定していないのに罫線が出ることは無いと思います。書式の設定で罫線の設定をしているのに出ないということはあります。出ない理由は分かりませんが、03の上が出なかったら02の下で出すという方法でやり過ごしています。

マクロボタンの連打はそのマクロが終了する前に連打していない限り無いと思いますが、マクロがボタン制御をしているかもしれませんのでわかりません。

どちらにしても、Windowsの種類も記載して新たに質問をすれば詳しい人(2016利用者など)が回答してくれるのではないでしょうか。

お礼

すみません。罫線ではなくて格子でした。O列に格子が出たり出なかったりと。
条件付き書式を全てクリアしてもう一度先程の書式を設定して試しても
上手くいきません。
色々やってる内に色々な問題って出るもんなんですねぇ。
こんなに出来なかったのは初めてです。

補足

後、特殊カウントが成功してたり、してなかったりもするんです。
成功してる所があるのに失敗する場合も有るとなると、ソースが悪いとは言えない気がします。
ア～コを0～9に変えてしてみたんですが0だけ必ずカウントミスしてます。

回答No.6

kkkkkm

> 罫線が付加されていったりとか。
>
> 故障なんですかね？中がちょっとごちゃついて整理しきれてない、とがあったりする
> んですかね？

故障かどうかは分かりませんが、勝手に罫線が付加されるというのは条件付き書式かVBAで設定することでしかできないように思います。もしかしたら何かしら他の設定があるのかもしれませんが、私にはちょっとわかりません。

また、条件付き書式の管理で「現在の選択範囲」で見ているのでしたら「このワークシート」で見ると他に設定が出てくることがあります。

お礼

クイック修復して試してもダメでした。
O列に罫線が加算されたりされなかったり。マクロボタンの連打に対応しきれなかったりする場合ってありますか？
後、先程の条件付き書式ではこれ１つだけの内容でした。
他のワークブックにも条件付き書式設定はなかったです。

回答No.5

kkkkkm

> 設定を=AND (D6=＄K＄10,＄K＄10＜＞″″)
> とし、色を橙色に設定、をし、
> 適用先を=＄D＄6:＄G＄20
> としてます。

一部全角なのはこのサイトのせいだとして
この設定しかなくK10の文字と違うセルが色付けされる( もしくは色設定を変えても一部元のままとか)のでしたらエクセルの問題ですね。
ブックの破損もあり得るので別に新しいブックでも試してみて、そちらでも同じようになるのならOffice2016の修復をしてみるとかですね。

あとは、条件付き書式がおかしいという事で新たに質問したほうがいいと思います。

お礼

Kkkkkm さん。いつもありがとうございます。office 2016 の修復があるとは思いもしませんでした。
そんなのがあるんですね。確かに、説明しきれてないおかしな事が他にもあるんです。
罫線が付加されていったりとか。

故障なんですかね？中がちょっとごちゃついて整理しきれてない、とがあったりするんですかね？
修復に期待します。また、何か回答頂けたら相談できてありがたいです。

回答No.4

kkkkkm

> Excelの問題だとウィルスとかになってくるのですか？

それは、「適切な条件付き書式」で設定しているかどうかによりますから何とも言えません。
複数の条件付き書式が設定されていてそちらが有効になっているとか、マクロ(VBA)で書式設定の色付けしてるとか(手動の書式設定で無色に戻せたのならこれの可能性もあります。条件付き書式で色付けされている場合、手動の書式設定では色の変更はできません)

とりあえず単独の「適切な条件付き書式」で色が残るのでしたらOffice2016の修復をしてみてもいいかもしれません。

まず、色付けがどのような形で行われているのか調査してみてください。

お礼

(D6 : G20) に 「数式を使用して、書式設定するセルを決定」をし、
設定を=AND (D6=＄K＄10,＄K＄10＜＞″″)
とし、色を橙色に設定、をし、
適用先を=＄D＄6:＄G＄20
としてます。

回答No.3

kkkkkm

> 希望でない形で黄色にそまったままだったりと…

適切な条件付き書式で色付けをしているのでしたらそのような事にはならないと思いますが、もしそうなるのでしたらエクセルの問題ですね。

お礼

条件色を変えてしてみても黄色で残ったりと、黄色に変わったところを無色に戻す必要がでます。Excel2007 からExcel2016 にかえたからですかね？
詳しくない者がパソコンを変えたので、その上でのこのくらいの疑問しか出てこないのが残念です。
Excelの問題だとウィルスとかになってくるのですか？