エクセル 白丸文字と黒丸文字の重複チェック

質問

S41(S41:AI47)のセルに下記のような丸文字があります。
（↓文字化けしてました）
　(1)❷ (3)(4)(5)(6)(7)❽ (9)　
以後、（）は○だと思ってください。❷は黒丸2　❽は黒丸8　です。

やりたい事：
1）
このS41のセル内の重複チェックしたい。（AK41　辺りに重複　の表示）
只、(2)❷など白丸文字と黒丸文字　は同じ値とし、チェックしたい（例　(2)❷　＝重複）
　（この丸文字は単語登録してありますので、➀(1)といった類似文字を間違って入力する事はないと思います。）

2）
(1)～(9)の数値が全部入力されているかの確認をしたい。

1）に関しては安易な考えなのですが可能なのであれば、（そもそもこのようなマクロは無いかもしれませんが）(1)＝1　(2)＝2　❷＝2と置き換えてAL41のセルに入力できるようにし、AL41を重複チェックしたら良いのか？など思っています。

優先的には、1）を重視したいです。

　エクセル2003を使用しています。
（2007でないとできないというのであれば　何とか成功させたいので2007導入も検討します）
環境依存文字で難しいのかもしれませんがよろしくお願いします。

回答No.6

Wendy02

#4 のユーザー定義関数に関して

Public Function CheckDoubles(ByVal rng As Range, Optional opt As Integer = 0) As
　　～
End Functon

同じブックの、標準モジュールに貼り付けます

'-------------------------------------------
シートの必要な場所に

= CheckDoubles(セルまたはセルの範囲)

例：
=CheckDoubles(S41)

足りない数値が出ます。

= CheckDoubles(セルまたはセルの範囲, 1 ) Opt は、0以外です。
ダブリの数字が出ます。

例：
=CheckDoubles(S41,1)

'-------------------------------------------
たったこれだけのことです。ヘルプは、現在の設定では出てきません。
なお、数式は、あまり多く使いますと、配列数式と同様、シートが重くなりますから、マクロで、定数化したほうが軽くなります。

回答No.5

_Kyle

#3です。

>実際にはスペースがあります。

よく見ると質問文の例にもちゃんとスペースが入ってますね^^;;
見落としていました、すみません。

#4さまがユーザー定義関数を提示されていますので、
もう不要かもしれませんが…。
-------------------------------------
作業セルをもう一つ用意し、対象セルに対してまず、

　=SUBSTITUTE(ASC(A1)," ",)

とすれば、(全半角問わず)スペースを除いた文字列が得られますから、
そのセルについて、#3と同様に変換,チェックをおこなえば結果が得られます。

　１．対象セル
　　↓
　２．スペース除去
　　↓
　３．変換
　　↓
　４-１．重複チェック
　４-２．欠落チェック

という順です。

一応ご参考まで。

お礼

度々、ありがとうございます。
できました！感激です。
エクセルって本当に奥が深くすごいんですね。
（皆様の様に使いこなせればですけど・・・）

＃1の回答者様の方法と併用で使っていきたいと思います。

回答No.4

Wendy02

こんにちは。

ユーザー定義関数に換えてみました。あくまでも、VBAをご存知の方に対するものですから、こちらから、あまり初歩的な説明をするつもりはありません。組み込んでお使いになれるようなら、お試しください。組み込み関数では出来ないことが可能かと思います。

ユーザー定義関数の数式は、

不足している数字
=CheckDoubles(A1:J1)

重複している数字
=CheckDoubles(A1:J1, 1)

単独セルでも、複数セルでも検索可能です。
重複がない場合は、空文字「""」が出力しています。

なお、
　 'パターン
　 mPattern = "\u2460-\u2468\u2776-\u277E"

文字範囲は、Unicode になっていますから、その範囲を指定すればよいのですが、
If n > 10 ^ 4 Then n = n - 10101
If n > 9 * 10 ^ 3 Then n = n - 9311
ここで、数値に変換しています。ただし、配列は、数字（文字)に変換しています。

'-------------------------------------------
'標準モジュール
'-------------------------------------------

Public Function CheckDoubles(ByVal rng As Range, Optional opt As Integer = 0) As String
　　Dim buf() As Variant
　　Dim misbuf() As Variant
　　Dim dbuf() As Variant
　　Dim dbbuf() As Variant
　　Dim n As Variant
　　Dim s As String
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim c As Variant
　　Dim v As Variant
　　Dim ret As Variant
　　Dim Matches As Object
　　Dim Match As Object
　　Dim mPattern As String
　　Dim List1 As Variant
　　Dim List2 As Variant
　　'パターン
　　mPattern = "\u2460-\u2468\u2776-\u277E"
　　If WorksheetFunction.CountA(rng) = 0 Then Exit Function
　　With CreateObject("VBScript.RegExp")
　　　　.Global = False
　　　　.Pattern = ".*[" & mPattern & "].*"
　　　　For Each c In rng
　　　　　　For k = 1 To Len(c.Value)
　　　　　　　　s = Mid$(c.Value, k, 1)
　　　　　　　　If .Test(s) Then
　　　　　　　　　　Set Matches = .Execute(s)
　　　　　　　　　　n = AscW(Matches(0).Value)
　　　　　　　　　　If n > 10 ^ 4 Then n = n - 10101
　　　　　　　　　　If n > 9 * 10 ^ 3 Then n = n - 9311
　　　　　　　　　　On Error Resume Next
　　　　　　　　　　ret = Application.Match(CStr(n), buf, 0)
　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　If IsError(ret) Or IsEmpty(ret) Then
　　　　　　　　　　　　ReDim Preserve buf(i)
　　　　　　　　　　　　buf(i) = CStr(n)
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　Else
　　　　　　　　　　　　ReDim Preserve dbuf(j)
　　　　　　　　　　　　dbuf(j) = CStr(n)
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next k
　　　　Next c
　　　　'MissingList
　　　　j = 0
　　　　For i = 1 To 9
　　　　　　ret = Application.Match(CStr(i), buf, 0)
　　　　　　If Not IsNumeric(ret) Or IsEmpty(ret) Then
　　　　　　　　ReDim Preserve misbuf(j)
　　　　　　　　misbuf(j) = CStr(i)
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next i
　　　　'DoublingList
　　　　On Error Resume Next
　　　　ret = Empty
　　　　ret = LBound(dbuf)
　　　　On Error GoTo 0
　　　　j = 0
　　　　If Not IsEmpty(ret) Then
　　　　　　For Each v In dbuf
　　　　　　　　ret = Empty
　　　　　　　　On Error Resume Next
　　　　　　　　ret = Application.Match(CStr(v), dbbuf, 0)
　　　　　　　　On Error GoTo 0
　　　　　　　　If IsError(ret) Or IsEmpty(ret) Then
　　　　　　　　　　ReDim Preserve dbbuf(j)
　　　　　　　　　　dbbuf(j) = CStr(v)
　　　　　　　　　　j = j + 1
　　　　　　　　End If
　　　　　　Next v
　　　　End If
　　　　List1 = Join(misbuf, ",")
　　　　List2 = Join(dbbuf, ",")
　　　　If opt <> 0 Then opt = 1
　　　　CheckDoubles = Array(List1, List2)(opt)
　　End With
End Function

お礼

何度もありがとうございます。
色々試させてもらいましたが私では使いこなせませんでした。（ヘルプなど確認しましたがRng 、Opt など検索できませんでした）
（関数の挿入→CheckDoubles→　Rng と　Opt 共にS41を指定してみたりしましたが駄目でした）

折角、素晴らしいものを提供してもらいましたが申し訳ありません。

　最初に教えていただい方法ならわかりますので使っていきたいと思っています。そこでお願いがあるのですが、1～8など　9個なかった時（重複なし時）に、重複なし　という表示のみで　不足している数が出ないことに気づきました。　お時間がある時かまいませんので、修正可能ならして頂けると助かります。

回答No.3

_Kyle

・複数の丸付数字が単一のセルに入っている
・数字は１～９までに限る
・黒丸付数字と白丸付数字は判定上区別しない
という解釈であってますか？
------------------------------
作業セルを使えば、数式でもなんとかなります。

以下、投稿の都合上、
・白丸数字の1～9を、あいうえおかきくけ
・黒丸数字の1～9を、アイウエオカキクケ
で代用して表記します。
------------------------------
●変換(作業セル)

　対象セルがA1であるとして、

　=TEXT(SUMPRODUCT(10^(INT(FIND(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1),"†あアいイうウえエおオかカきキくクけケ")/2)-1)),REPT("0",9))

　とすると、9文字の数字列が表示されます。

　下第N桁の数字は、丸付数字Nの個数を表します。
　111111211　⇒　下第3桁が2　⇒　3が重複
　111011111　⇒　下第6桁が0　⇒　6が欠落
------------------------------
●重複チェック

　作業セルがB1であるとして、

　=IF(MAX(INDEX(--MID(B1,ROW(INDIRECT("1:9")),1),))>1,"#重複!!","OK!")

　とすれば、重複がある場合に、"#重複!!"　と表示されます。　
------------------------------
●欠落チェック

　作業セルがB1であるとして、

　=IF(ISERR(FIND("0",B1)),"OK!","#欠落!!")

　とすれば、欠落がある場合に、"#欠落!!"　と表示されます。
------------------------------
なお、

　(6)(6)(6)(6)(6)(6)(6)(6)(6)(6)

のように、
【変換した数字列の桁が繰り上がってしまうほど】
多くの重複がある場合には
正しい結果が得られない可能性があります、念のため。

以上ご参考まで。

お礼

ありがとうございます。
解釈はそのとおりです。

只、質問の仕方が悪く実際にはスペースがあります。最初にスペースが必ずきまして途中にも2～4個、」合計3個～5個入ってきます
例）　スあいスうえオカきスくケ
ス＝全角スペース
（質問時にスペースあけてたつもりでしたが、前詰めされて表示されていました）

スペースなし状態ではバッチリでした。

それにしても数式のみでこんな表現ができるとは本当に凄いですね。私からすれば神の領域です。

回答No.2

Wendy02

#1の回答者です。

もともとは、ユーザー関数を想定したものですが、#1の回答で書いたとおり、ご質問の内容では、読み取れません。ただ、丸付き数字のダブりや不足を検出できるというところまでしか組み込ませんでした。

求めるものが、実際に具体的にはどういうものかも分かりません。単に、True, False だけでは足りそうもないようですし、かといって、あまり複雑なものでは、ユーザー定義関数で出力するのも難しくなります。

ですから、#1のマクロをモジュールに貼り付けたところで、コードをある程度分からない状態では、まったく動きません。

>S41(S41:AI47)のセルに下記のような丸文字があります。
>このS41のセル内の重複チェックしたい。（AK41　辺りに重複　の表示）

データが、S41:AI47までとしても、S41のセル内？　AK41辺りに重複の表示？という表現では、一体にどこにどう出すのか、どのように理解していいのか、理解できません。

シートモジュール？すみませんが、良く分かりません。シートモジュールというのは、イベント・ドリブン型にするという意味でしょうか？シートモジュールでは、それ以外の使い道は、よほどの初心者でなければ、そこを使うことはありません。

なお、
Test1 の
Set rng = Range("A1:K1")
に範囲を入れると、ユーザー定義関数に渡されます。

お礼

ありがとうございます。
説明不足ですみません。

マクロは少し触れた程度の初心者です。標準モジュール＝都度マクロ実行をしなければならないものだと思ってまして、シートモジュールならなにもしなくても実行させるのかと思ってました。

質問内容は
３番目の回答者様が書いてくれていました内容
・複数の丸付数字が単一のセルに入っている
・数字は１～９までに限る
・黒丸付数字と白丸付数字は判定上区別しない

後、S41:AI47は　結合してありS41になっているという意味でした。
素人の考えで　AK41に重複などのエラーがありましたら表示できればと思っていました。
フォームボタンを作って都度実行してやってみます。

それにしても、皆さん頭が下がります。素晴らしいの一言です。
ありがとうございました。

回答No.1

Wendy02

こんばんは。

ご質問は読み取れませんでしたが、重複のチェックは可能です。

'-------------------------------------------
'標準モジュール
'-------------------------------------------

Sub Test1()
　　Dim i As Long
　　Dim j As Long
　　Dim msg As String
　　Dim msg2 As String
　　Dim rng As Range
　　Dim ret As Variant
　　Dim n As Variant
　　Dim List1 As Variant
　　Dim List2 As Variant

　　Set rng = Range("A1:K1")

　　ret = CheckDouble(rng, List1, List2)
　　On Error Resume Next
　　'ダミー
　　If List1(0) = 0 Then GoTo EndLine
　　On Error GoTo 0
　　For i = 1 To 9
　　　　n = Application.Match(i, List1, 0)
　　　　If IsError(n) Then
　　　　　　msg = msg & "," & i
　　　　End If
　　Next i
　　If ret = True Then
　　　　For j = 0 To UBound(List2)
　　　　　　msg2 = msg2 & "/" & List2(j)
　　　　Next j
　　End If
　　If msg = "" Then
　　　　msg = "1～9まであります。"
　　Else
　　　　msg = "足りない数字 " & Mid$(msg, 2)
　　End If
　　If msg2 = "" Then
　　　　msg = "重複はありません。"
　　Else
　　　　msg2 = "重複している数字 " & Mid$(msg2, 2)
　　End If
　　MsgBox msg & vbCrLf & msg2
EndLine:
　　Set rng = Nothing
End Sub

Function CheckDouble(ByVal rng As Range, ByRef List1 As Variant, ByRef List2 As Variant)
　　Dim buf() As Long
　　Dim dbuf() As Long
　　Dim n As Variant
　　Dim s As String
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim c As Variant
　　Dim ret As Variant
　　Dim Matches As Object
　　Dim Match As Object
　　Dim flg As Boolean
　　Dim mPattern As String
　　flg = False

　　mPattern = "\u2460-\u2468\u2776-\u277E"

　　With CreateObject("VBScript.RegExp")
　　　　.Global = False
　　　　.Pattern = ".*[" & mPattern & "].*"
　　　　For Each c In rng
　　　　　　For k = 1 To Len(c.Value)
　　　　　　s = Mid$(c.Value, k, 1)
　　　　　　If .Test(s) Then
　　　　　　　　Set Matches = .Execute(s)
　　　　　　　　　　n = AscW(Matches(0).Value)
　　　　　　　　　　If n > 10 ^ 4 Then n = n - 10101
　　　　　　　　　　If n > 9 * 10 ^ 3 Then n = n - 9311
　　　　　　　　　　On Error Resume Next
　　　　　　　　　　ret = Application.Match(n, buf, 0)
　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　If IsError(ret) Or IsEmpty(ret) Then
　　　　　　　　　　　　ReDim Preserve buf(i)
　　　　　　　　　　　　buf(i) = n
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　Else
　　　　　　　　　　　　ReDim Preserve dbuf(j)
　　　　　　　　　　　　dbuf(j) = n
　　　　　　　　　　　　j = j + 1
　　　　　　　　　　　　flg = True
　　　　　　　　　　End If
　　　　　　End If
　　　　　　Next k
　　　　Next c
　　　　List1 = buf
　　　　List2 = dbuf
　　　　CheckDouble = flg
　　End With
End Function
'-------------------------------------------

お礼

ありがとうございます。
色々試していますが、マクロ実行しても何も反応ありません。
どこのセルに値を入れたらよいのでしょうか？

できましたら、マクロ実行をしなくても自動で実行されるものがよいのですがよろしくお願いします。（シートモジュールになるのでしょうか？）