2010 ｅｘｃｅｌ マクロ 記号の変化

質問

エラー発生で強制終了になってしまいます。2007年のｅｘｃｅｌで作成したものですが、2010だと強制終了になってしまいます。
内容は□をダブルクリックすると■になるように作っています。
記述は2003年からのマクロ記述なので、変化が必要なのでしょうか？

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'セルをダブルクリックすると、・→○→△→×→・と変更する。
Dim S1 As String
Dim S2 As String
Dim S01 As String
Dim S02 As String
Dim S03 As String
Dim S04 As String

S1 = "□"
S2 = "■"
S01 = "・"
S02 = "○"
S03 = "△"
S04 = "×"

On Error GoTo ERR_12

sCheckXY S1, S2

sCheckX1234 S01, S02, S03, S04

sChangeXY S1, S2

Exit Sub

ERR_12:
End

End Sub

Sub sChangeXY(X As String, Y As String)

'選択セルに□があれば■に変える

Dim Str0 As String 'str1の左端
Dim Str1 As String 'strの右側更新
Dim Str2 As String 'strの左側更新
Dim Str20 As String 'strの左側一部保存
Dim L As Long
Dim M As Long
Dim N As Long

Str1 = ActiveCell.Text
L = Len(Str1)

Debug.Print L
If L = 0 Then
End
End If

For N = 1 To L
Debug.Print Str2
Str0 = Left(Str1, 1)

If Str0 = X Or N = L Then
If Str20 <> "" Then
If N = L Then
Str20 = Str20 + Str0
End If
If MsgBox(Str20 & "　　はチェックしますか？", vbYesNo, "選択肢") = vbYes Then
Str2 = Str2 + Replace(Str20, X, Y)
Str20 = Str0

Else
Str2 = Str2 + Replace(Str20, Y, X)
Str20 = Str0

End If
Else
Str20 = Str0

End If

Else
Str20 = Str20 + Str0

End If
Str1 = Right(Str1, L - N)
Next N

ActiveCell.Value = Str2

End Sub

Sub sCheckXY(X As String, Y As String)
'選択セルがXならY,YならXにチェックをかえる
If ActiveCell.Text = X Then
ActiveCell.Value = Y
End
ElseIf ActiveCell.Text = Y Then
ActiveCell.Value = X
End
End If

End Sub

Sub sCheckX1234(X1 As String, X2 As String, X3 As String, X4 As String)
'選択セルがXならY,YならXにチェックをかえる
If ActiveCell.Text = X1 Then
ActiveCell.Value = X2
End
ElseIf ActiveCell.Text = X2 Then
ActiveCell.Value = X3
End
ElseIf ActiveCell.Text = X3 Then
ActiveCell.Value = X4
End
ElseIf ActiveCell.Text = X4 Then
ActiveCell.Value = X1
End
End If

End Sub

回答No.7

cj_mover · ベストアンサー

たまたま仕事で似通ったテーマ扱ったので、
自分の好みで仕様を一から考えて書いてみました。ので上げてみます。
視覚的なわかり易さ、編集し易い構造（コード）、汎用性（機能）など多少意識してます。
敢えてエラートラップ外してますが、まま使えるかと。
パーツは色々替えてみたいですけど、手軽に済ませてます。
（マトリックス用ソート関数使いたいけど、小数の簡易ソートで代用、とか。）
後は、さて、そもそもどんなニーズだったんだろう？ってことですけど、
試してもらえたらなって思っています。
私には、レスがなくてもいいので。

' ' ================================================================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim sMark1 As String
　　Dim sMark2 As String
　　Dim sSource As String

　　' ' 処理をする必要のない範囲、が、はっきりしているなら、下の例のように抜ける処理
　　' If Target.Column > 5 Then Exit Sub

　　' ' ダブルクリック後、セルを編集状態にしたくない場合は、下の行を活かす
　　' Cancel = True

　　sMark1 = "□■"
　　sMark2 = "・○△×"
　　' ' 上のように直値で指定する場合以外では文字長をチェック

　　sSource = Target(1).Text
　　Select Case Len(sSource)
　　Case 0: Exit Sub
　　Case 1
　　　　If ShiftMark(sSource, sMark1, sMark2) Then Target(1).Value = sSource
　　Case Else
　　　　If RehashShiftMark_HashedText(sSource, sMark1) Then Target(1).Value = sSource
　　End Select
End Sub
' ' ================================================================
' ' ================================================================
Function ShiftMark(sSource As String, ParamArray paMark()) As Boolean ' sSourceは１文字
　　Dim sMark
　　Dim nDigit As Long
　　For Each sMark In paMark
　　　　nDigit = InStr(sMark, sSource)
　　　　If nDigit > 0 Then
　　　　　　sSource = Mid$(sMark, nDigit Mod Len(sMark) + 1, 1)
　　　　　　ShiftMark = True
　　　　　　Exit For
　　　　End If
　　Next sMark
End Function
' ' ================================================================
Function RehashShiftMark_HashedText(sSource As String, sMark As String) As Boolean ' sMarkは２～９文字
　　Dim arrPos() As Single, arrPosS() As Single
　　Dim sTemp As String, sMsg As String, sRep As String
　　Dim nLenM As Long, nCur As Long, nNewM As Long
　　Dim i As Long, nCnt As Long, nPos As Long
　　Dim flg As Boolean

　　nLenM = Len(sMark)
　　ReDim arrMark(1 To nLenM)
' ' マークが見つかった位置（整数）＋置換後のマークの桁位置(小数部）を配列に arrPos()
' ' マークを１文字ずつ配列に arrMark()
' ' マークの個数をカウント nCnt
　　For i = 1 To nLenM
　　　　nPos = 0
　　　　nNewM = (i Mod nLenM + 1)
　　　　sTemp = Mid$(sMark, i, 1)
　　　　Do
　　　　　　nPos = InStr(nPos + 1, sSource, sTemp)
　　　　　　If nPos > 0 Then
　　　　　　　　ReDim Preserve arrPos(nCnt) As Single
　　　　　　　　arrPos(nCnt) = nPos + nNewM * 0.1
　　　　　　　　nCnt = nCnt + 1
　　　　　　Else
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop 'While nPos
　　　　arrMark(i) = sTemp
　　Next i

　　If nCnt = 0 Then Exit Function

' ' ソート　arrPos() → arrPosS()
　　ReDim arrPosS(1 To nCnt + 1) As Single
　　For i = 1 To nCnt
　　　　arrPosS(i) = Application.Small(arrPos, i)
　　Next i
　　arrPosS(nCnt + 1) = Len(sSource) + 1

' ' 置換
　　For i = 1 To nCnt
　　　　nCur = arrPosS(i) ' 置換位置
　　　　sRep = arrMark((arrPosS(i) - nCur) * 10) ' 置換後のマーク
　　　　If arrPosS(i + 1) > nCur + 25 Then ' 表示用に文字列抜きだし
　　　　　　sTemp = Mid$(sSource, nCur, 25) & "．．．"
　　　　Else
　　　　　　sTemp = Mid$(sSource, nCur, arrPosS(i + 1) - nCur)
　　　　End If
　　　　sMsg = sSource & vbLf & vbLf & nCur & " 文字めにある　" & i & " 個目のマークを更新しますか？" _
　　　　　　　　& vbLf & vbTab & sTemp & vbLf & vbTab & "↓" & vbLf & vbTab & sRep
　　　　Select Case MsgBox(sMsg, vbYesNoCancel, "選択肢　：　" & i)
　　　　Case vbYes
　　　　　　flg = True
　　　　　　Mid(sSource, nCur) = sRep
　　　　Case vbCancel: Exit Function
　　　　End Select
　　Next i

　　RehashShiftMark_HashedText = flg
End Function
' ' ================================================================

／／／
＃こちらこそ、大変勉強になりました。ありがとうございます。
機会がありましたらまた勉強させてください。

回答No.6

30246kiku

＃４です

Excel の VBA は不慣れなので・・・

セルを結合していた時の書き方があるんですね・・・
勉強になりました・・・

ありがとうございます。

回答No.5

cj_mover

あ、えっと、ひとつ気が付いたので修正入れときますね。
#2のコード
> sText = Target.Text
これは
　sText = Target(1).Text
の方が良かったですね。２か所、修正が必要です。
もしかして、結合セルをダブルクリックしている場合は、
私の#2では、「ビープ音鳴ってエラー」です。
その対策ということになります。

なるほど、だから、ActiveCellとか使ったコードに落ち着いちゃったのかも知れませんね。

えっとセルの結合使っている場合は、
30246kikuさんがお書きになったものも
> sS = Target
も、２か所
sS = Target(1)
とかに換えてから動かしてあげてくださいませ。

お手数おかけします。

回答No.4

30246kiku

VBA は、いろんな人のものを見た方が良いと思うので、参考になるところがあれば・・・
無理に関数を作らなくても・・・・っていう時の書き方の一例（になるかどうか？）

提示された仕様を以下と解釈
・１文字の場合
　記号であれば無条件置換
　記号でなければ空文字に
・複数文字の場合
　大半は、文字列を挟む形で□や■が前後にあり、それを同時に置き換えたい

前提条件)　各記号は１文字であること

以下、提示されたものとほぼ一緒の動きかと
（メッセージを出す際、□■が含まれていなければ出さない部分が異なるだけかと）

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim sS As String, sR As String, sTmp As String
　　Dim i As Long, iPos As Long
　　Const CS1 As String = "□■"
　　Const CS2 As String = "・○△×"
　　Const CSQ1 As Long = 1
　　Const CSQ2 As Long = 2

　　sS = Target
　　If (Len(sS) = 0) Then Exit Sub
　　sR = ""
　　If (Len(sS) = 1) Then
　　　　i = InStr(CS1, sS)
　　　　If (i > 0) Then
　　　　　　sR = Mid(CS1, 3 - i, 1)
　　　　Else
　　　　　　i = InStr(CS2, sS)
　　　　　　If (i > 0) Then sR = Mid(CS2, (i Mod Len(CS2)) + 1, 1)
　　　　End If
　　Else
　　　　iPos = 1
　　　　While (Len(sS) > 0)
　　　　　　i = InStr(iPos, sS, Mid(CS1, CSQ1, 1))
　　　　　　If ((i = 0) Or (i = Len(sS))) Then i = Len(sS) + 1
　　　　　　sTmp = Left(sS, i - 1)
　　　　　　sS = Mid(sS, i)
　　　　　　iPos = 2
　　　　　　If (Len(sTmp) > 0) Then
　　　　　　　　If ((InStr(sTmp, Mid(CS1, CSQ1, 1)) > 0) Or (InStr(sTmp, Mid(CS1, CSQ2, 1)) > 0)) Then
　　　　　　　　　　If (MsgBox(sTmp & "　　はチェックしますか？", vbYesNo, "選択肢") = vbYes) Then
　　　　　　　　　　　　sTmp = Replace(sTmp, Mid(CS1, CSQ1, 1), Mid(CS1, CSQ2, 1))
　　　　　　　　　　Else
　　　　　　　　　　　　sTmp = Replace(sTmp, Mid(CS1, CSQ2, 1), Mid(CS1, CSQ1, 1))
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　sR = sR & sTmp
　　　　　　End If
　　　　Wend
　　End If
　　Target = sR
End Sub

以下は仕様を若干変更
・１文字の場合
　記号であれば無条件置換
　記号でなければそのまま　★
・複数文字の場合
　□■が出現するごとにメッセージボックス表示し、置換するか・・・　★

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim sS As String
　　Dim i As Long, j As Long
　　Const CS1 As String = "□■"
　　Const CS2 As String = "・○△×"

　　sS = Target
　　If (Len(sS) = 0) Then Exit Sub
　　If (Len(sS) = 1) Then
　　　　i = InStr(CS1, sS)
　　　　If (i > 0) Then
　　　　　　sS = Mid(CS1, 3 - i, 1)
　　　　Else
　　　　　　i = InStr(CS2, sS)
　　　　　　If (i > 0) Then sS = Mid(CS2, (i Mod Len(CS2)) + 1, 1)
　　　　End If
　　Else
　　　　For i = 1 To Len(sS)
　　　　　　j = InStr(CS1, Mid(sS, i, 1))
　　　　　　If (j > 0) Then
　　　　　　　　If (MsgBox(Mid(sS, i) & "　　の先頭を置き換えますか？" _
　　　　　　　　　　　　　　　　　　　　, vbYesNo, "選択肢") = vbYes) Then
　　　　　　　　　　Mid(sS, i, 1) = Mid(CS1, 3 - j, 1)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End If
　　Target = sS
End Sub

※ 2007 で確認したものなので、2010 で動かなかったらごめんなさい。
※ もし、転記、確認される場合があれば、教えてgoo ではない提携サイトから
　　コピー＆貼り付けしてください。
　　（現在の教えてgoo では、不要な半角スペースが行頭に付加されるようです）
　　（だからと言って、動作には影響ないと思いますが）

回答No.3

cj_mover

#2について。
> この記述を真似したのですが、すいませんただ単に貼り付けて使ったのですが・・うまく動かなかったです。
もしかして
　　If Target.Column > 5 Then Exit Sub
この記述↑もそのままでしょうか？
A:Eの範囲でのダブルクリックでのみ機能して、それ以外は Exit Sub しています。
Exit Sub の使用例なのですが、説明しておいた方がよかったですかね。
すべてのセルでダブルクリック後の処理を必ず実行するのではなくて、
必要でない範囲であればイベントＰの一行目で抜けてしまうようにして
余計なストレスを減らそう、という、これもイベントＰとしては極一般的な記述です。
そのままですと、Ｆ列から右の列ではすべて、何もしないで抜けてしまいます。
記述の中のこの一行だけ削除したら、どのような結果なのでしょうか。

もっとも"うまく動かなかったです"では、どんな様子かわかりませんので
ちょっと困りました。

一応、手元のサンプルデータではご提示のものとほぼ同じように機能することは確認しているのですが
すみません。
よろしければ、求める結果とどう違うか、教えて頂けませんか。
その上で、対策が必要ならお応えするつもりはあります。
しかし、ことさら私が書いたものをゴリ押しする気もないので
そちらの方で解決の目途がたったなら、それはそれで結構です。

回答No.2

cj_mover

こんにちは

一応、書いてみたので、一応、あげてみます。
Exit Sub の扱い、とか、参考になるでしょうか。

若干、求める仕様と違うかも知れません。

子Ｐの
　sText = Target.Text
とか
　If Len(sText) <> 1 Then Exit Sub
　If nDigit = 0 Then Exit Sub
とかは
本来、親Ｐで処理した方がよさそうなものですが、読み易さを優先しました。

子Ｐを２種にして、分けて書くメリットを出そうという意図なのですけれど、
Toggleの方なんかは、普段の私なら親Ｐ（もしくはイベントＰから呼び出す親Ｐ）
の方にもっと簡単に書いていくと思います。
或いは、子Ｐには文字列だけ処理させるように
参照渡しにするとかモジュール変数にするとかFunctionにするとか
改善の余地はあります。

好みによっては Exit Sub を使わない書き振りもありそうですが、
「終わらせないで、抜ける」テーマで書いたもの、です。
サンプルなので、使わず捨てるとかいじるとか真似るとか、ご自由にどうぞ。

Excel2010で動作テストはしています。

' ' ================================================================
Option Explicit
' ' ================================================================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim sTg1 As String
　　Dim sTg2 As String
　　Dim flg As Boolean

　　If Target.Column > 5 Then Exit Sub
　　Cancel = True

　　sTg1 = "□■"
　　sTg2 = "・○△×"

On Error GoTo errHndl_

　　Call StrShift(Target, sTg1, flg)
　　If flg Then Exit Sub

　　Call StrShift(Target, sTg2, flg)
　　If flg Then Exit Sub

　　Call StrToggleRehash(Target, sTg1)
　　Exit Sub

errHndl_:
　　If Err.Number Then Debug.? Err.Number, Err.Description: Beep
　　Exit Sub
End Sub
' ' ================================================================

' ' ================================================================
Sub StrShift(ByVal Target As Range, ByVal sTg As String, Optional ByRef flg As Boolean)
　　Dim sText As String
　　Dim nLen As Long, nDigit As Long

　　sText = Target.Text
　　If Len(sText) <> 1 Then Exit Sub

　　nDigit = InStr(sTg, sText)
　　If nDigit = 0 Then Exit Sub

　　nLen = Len(sTg)

　　Target.Value = Mid$(sTg, nDigit Mod nLen + 1, 1)
　　flg = True
End Sub
' ' ================================================================
Sub StrToggleRehash(ByVal Target As Range, ByVal sTg As String)
　　Dim sText As String, sTemp As String
　　Dim nLen As Long, nDigit2 As Long
　　Dim i As Long

　　sText = Target.Text
　　If Len(sText) = 0 Then Exit Sub

　　nLen = Len(sTg)
　　If nLen <> 2 Then Exit Sub

　　For i = 1 To nLen
　　　　sTemp = Mid$(sTg, i, 1)

　　　　nDigit2 = InStrRev(sText, sTemp) ' InStrRev | InStr ?

　　　　If nDigit2 > 0 Then
　　　　　　If MsgBox(sText & "　　はチェックしますか？", vbYesNo, "選択肢") = vbYes Xor i <> 1 Then
　　　　　　　　Mid(sText, nDigit2) = Mid$(sTg, i Mod nLen + 1, 1)
　　　　　　　　Target.Value = sText
　　　　　　End If
　　　　　　Exit For
　　　　End If
　　Next i
End Sub
' ' ================================================================

補足

ありがとうございます。この記述を真似したのですが、すいませんただ単に貼り付けて使ったのですが・・うまく動かなかったです。

回答No.1

cj_mover

シンプルに

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
　　End
End Sub

↑これはマズイですよね。簡単に落ちます。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
'
　　End
End Sub

まだしも、↑これなら、落ちないみたいです。

そもそも何故、End ステートメント なのか、不思議な使い方ですけれど
例えばWorksheetのイベントプロシージャについては
プロジェクトを破棄するのではなく
きちんと Exit Sub または End Sub で抜けるべきものなのでは？と思います。
（私も昔、モーダルなフォームなんか使っていて抜けるの忘れて失敗したことありますけど）
その点はバージョンの問題というより、
ネストレベルが低いバージョンでは露見しにくいとか、その手の話なんじゃないかなぁ？と。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
'
　　Exit Sub
End Sub

↑とかなら普通に見かける記述です。
子プロシージャが処理を全うしたかどうか戻り値を取るようにして
親側で条件により Exit Sub するようにするとか、方法は色々あると思います。
（そもそも強引に構造化することが良い方に働いてないような印象は受けますが）

とりあえず、
■　　End
■　　Cancel = True
■　　Exit Sub
の３点、ご確認ください。

お礼

ありがとうございます。Cancel = Trueほかの3点で試してみます。