こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

2010 excel マクロ 記号の変化

エラー発生で強制終了になってしまいます。2007年のexcelで作成したものですが、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

投稿日時 - 2012-09-26 08:00:51

QNo.7717597

すぐに回答ほしいです

質問者が選んだベストアンサー

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

' ' ================================================================
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は1文字
  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は2~9文字
  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()
' ' マークを1文字ずつ配列に 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
' ' ================================================================

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

投稿日時 - 2012-09-30 06:35:53

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(7)

ANo.6

#4です

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

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

ありがとうございます。

投稿日時 - 2012-09-28 08:13:52

ANo.5

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

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

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

お手数おかけします。

投稿日時 - 2012-09-28 04:52:19

ANo.4

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

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

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

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

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


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

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 では、不要な半角スペースが行頭に付加されるようです)
  (だからと言って、動作には影響ないと思いますが)

投稿日時 - 2012-09-27 23:39:03

ANo.3

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

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

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

投稿日時 - 2012-09-27 22:46:23

ANo.2

こんにちは

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

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

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

子Pを2種にして、分けて書くメリットを出そうという意図なのですけれど、
Toggleの方なんかは、普段の私なら親P(もしくはイベントPから呼び出す親P)
の方にもっと簡単に書いていくと思います。
或いは、子Pには文字列だけ処理させるように
参照渡しにするとかモジュール変数にするとか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
' ' ================================================================

投稿日時 - 2012-09-26 16:43:58

補足

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

投稿日時 - 2012-09-27 21:42:57

ANo.1

シンプルに

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
の3点、ご確認ください。

投稿日時 - 2012-09-26 11:08:26

お礼

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

投稿日時 - 2012-09-27 21:43:03

あなたにオススメの質問