29610
やりたいことは以下の通りです。

①対象セル群のうち一つに文字列を入力し、下キーまたはTabキーで移動する  
②その際、セルの文字列のうち、特定の文字をReplace関数で１個から２個に増やす  
※対象セル群はD列の２行目以下全てを対象とする

上記内容は下記コードで概ね実現出来たのですが、問題が残っております。

①やや冗長に感じる  
②範囲指定がうまくいっていない  
・D列セルから下に移動した時にコードが実行されない。  
・なぜかE列では下移動時のコードが実行される。  
ただ、セルが二度目にアクティブになった時に実行される。  
しかし、E列では右移動時コードは実行されない。

以上、どなたかアドバイスを頂けないでしょうか。  
何卒よろしくお願いいたします。

```

        Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    
        '①アクティブセルの一つ左のセル(LeftCell)の内容を操作する。
        Dim LeftCell As Range, i As Long, kazA As Long
        Set LeftCell = ActiveCell.Previous
    
        '②アクティブセルの一つ上のセル(UperCell)の内容を操作する。
        Dim UperCell As Range, ii As Long, kazB As Long
        Set UperCell = ActiveCell.Offset(-1, 0)
    
             'LeftCell内の、２個にしたい文字をカウントする
             For i = 1 To Len(LeftCell)
    
                 If Mid(LeftCell, i, 1) = "＠" Then kazA = kazA + 1
    
            Next i
    
    
            'UperCell内の、２個にしたい文字をカウントする
            For ii = 1 To Len(UperCell)
    
                 If Mid(UperCell, ii, 1) = "＠" Then kazB = kazB + 1
    
            Next ii
    
    
          'D列の２行目以下の範囲で、
            If ActiveCell.row >= 2 And _
               ActiveCell.Column = 5 Then
    
    
                    '文字のカウントの結果が１個だけであり、LeftCellがアクティブでなくなったら
                    If kazA = 1 And LeftCell <> ActiveCell.Previous.Address Then
    
                        'LeftCell内の１個の文字を２個に置き換える
                        LeftCell = Replace(LeftCell, "＠", "＠＠")
    
                    'または、文字のカウントの結果が１個だけでありUperCellがアクティブでなくなったら
                    ElseIf kazB = 1 And UperCell <> ActiveCell.Previous.Address Then
    
                        'UperCell内の１個の文字を２個に置き換える
                        UperCell = Replace(UperCell, "＠", "＠＠")
    
                End If
    
            End If
    
        End Sub
    
```
CC BY-SA 3.0
2016-10-16T05:41:03.963
29604
2016-10-16T13:27:49.997
7470
question
excel vba
入力を終えたセル内の特定の文字列の数を増やしたい
各所にブレークポイントを設定するなどして、各変数やプロパティの値が何になっているかを調べてみるとよいと思います。

  * ActiveCell = 移動後のセル
  * LeftCell = ActiveCell.Previous = 移動後のセルの左
  * UperCell = ActiveCell.Offset(-1,0) = 移動後のセルの上

それを踏まえると・・・

```

    If ActiveCell.row >= 2 And _
       ActiveCell.Column = 5 Then
    
```

これは移動後のセルがE列2行目であることを確かめていますから、D列で下に移動した場合には該当しません。D列で右に移動した時や、E列で下に移動したときに該当します。

```

    '文字のカウントの結果が１個だけであり、LeftCellがアクティブでなくなったら
    If kazA = 1 And LeftCell <> ActiveCell.Previous.Address Then
    
```

LeftCellの座標とActiveCell.Previousの座標を比較したいようですが、Rangeオブジェクトである `LeftCell`
の値を取得しようとすると、 `LeftCell.Value`
と書いた時のようにセルの内容が取得されます。「左隣のセルの内容」と「左隣のセルの座標」を比較してしまっているわけです。  
もっとも、座標の比較であればLeftCellとActiveCell.Previousは常に等しくなるわけですが・・・。

* * *

それはそれとして `SelectionChange` よりも、セルの内容が変更されたときに発生する `Change`
イベントの方がよいでしょう。このイベントでは変更されたセルを取得することができるので、左と上のどちらのセルが変更されたのか調べる必要がなくなります。

```

    Private Sub Worksheet_Change(ByVal Target As Range)
    
        Dim targetStr As String, count As Integer
    
        'D列の2行目以下でなければ終了
        If Target.Row < 2 Or Target.Column <> 4 Then Exit Sub
    
        targetStr = Target.Text
    
        'Target内の、2個にしたい文字をカウントする
        For i = 1 To Len(targetStr)
            If Mid(targetStr, i, 1) = "＠" Then count = count + 1
        Next i
    
        'カウント結果が1回なら
        If count = 1 Then
            Target.Value = Replace(targetStr, "＠", "＠＠")
        End If
    
    End Sub
    
```

他にも文字の出現回数の調べ方を変えたり、2個見つけた時点で数えるのをやめたり、3個以上存在する可能性を考慮しなくていいのであれば先に `＠＠` を `＠`
に置き換えたり、色々いじる余地はありますが、とりあえずはこれだけでも十分でしょう。
CC BY-SA 3.0
2016-10-16T13:27:49.997
29610
2016-10-16T13:27:49.997
8000
29604
answer