excel VBAで本文中の変換をするには

質問

エクセル２００２、OSXP使用しています。
エクセルで以下の変換（というか挿入？）をしたいのですが
---------
[n][n][n][n]
[d]
[n][n][n][n][n][n][n][n]
[d]
[n][n][n][n][n][n]
[d]
---------
↓
--------
[n1][n2][n3][n4]
[d]
[n1][n2][n3][n4][n5][n6][n7][n8]
[d]
[n1][n2][n3][n4][n5][n6]
[d]
----------
このようにnの後に数字の1を挿入し、次のnは2、その次は3，4・・・・
と数字が１づつ増えて挿入し、[d]が現れるとまたnの後に初めの1を挿入しその次は2,3,4というようにしたいのですが。[　]は特に意味はありません。
このようにできるソースを教えてください。宜しくお願いします。

回答No.1

Wendy02 · ベストアンサー

こんにちは。

詳しい例がなかったので、n -> n1, nn> n1n2 とするようにしました。

ごらんのとおり、
In Range("A1").CurrentRegion

ですから、Range("A1")から、続いているセルの範囲に対して実行します。
間が離れたり行が開いていたら、そこまでしかできません。変更の必要があれば、レスをつけてください。

Sub EnterLetter()
　　Dim c As Range
　　Dim i As Long
　　Dim j As Integer
　　Dim k As Integer
　　Const N As String = "n"　'検索文字
　　Const F As String = "d"　'初期化文字
　　i = 1
　　For Each c In Range("A1").CurrentRegion
　　　　k = 1
　　　　Do
　　　　 If InStr(k, c.Value, F, vbBinaryCompare) > 0 Then
　　　　　　i = 1
　　　　 End If
　　　　 k = InStr(k, c.Value, N, vbBinaryCompare)
　　　　 If k > 0 Then
　　　　 c.Value = Mid$(c.Value, 1, k) & CStr(i) & Mid$(c.Value, k + 1)
　　　　 i = i + 1:　　k = k + 1
　　　　 End If
　　　　Loop Until k = 0
　　Next c
End Sub

お礼

早速作成して頂き大変ありがとうございます。
試したみましたが、うまく挿入されました。
ありがとうございます。

回答No.2

pkh4989

こんにちは。

以下のマクロで試してみてください。

Sub 文字変換()
　　Dim x1　　 As Long
　　Dim c1　　 As Integer
　　'
　　With ActiveSheet
　　　　For x1 = 1 To .Range("A" & Rows.Count).End(xlUp).Row
　　　　　　If .Cells(x1, "A") = "n" Then
　　　　　　　　For c1 = 1 To .Cells(x1, "A").End(xlToRight).Column
　　　　　　　　　　.Cells(x1, c1) = .Cells(x1, c1) & c1
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　End With
End Sub