| |
検索文字の２文字目以降を置換すると良いようです。
ただし、検索文字が１文字だけのケースがあると上手く行かないです。
そこを無理やり処理してますが、もっと良い方法があるのかも。
Sub test()
Dim ws As Worksheet
Dim tb As TextBox
Dim chk As String
Dim rep As String
Dim n As Long
Dim p As Long
Dim x(8)
chk = "うえお"
rep = "こんにちは"
n = Len(chk) - 1
For Each ws In Worksheets
For Each tb In ws.TextBoxes
With tb
Do
p = InStr(.Text, chk)
If p = 0 Then Exit Do
If n > 0 Then
.Characters(p + 1, n).Insert rep
.Characters(p, 1).Delete
Else
With .Characters(p, 1).Font
x(0) = .Name
x(1) = .Size
x(2) = .Bold
x(3) = .Italic
x(4) = .Shadow
x(5) = .FontStyle
x(6) = .ColorIndex
x(7) = .OutlineFont
x(8) = .Strikethrough
End With
.Characters(p, 1).Insert rep
With .Characters(p, Len(rep)).Font
.Name = x(0)
.Size = x(1)
.Bold = x(2)
.Italic = x(3)
.Shadow = x(4)
.FontStyle = x(5)
.ColorIndex = x(6)
.OutlineFont = x(7)
.Strikethrough = x(8)
End With
End If
Loop
End With
Next
Next
End Sub
また、Characters().Fontから下線などの情報がどうしても取れないみたいですね。
『Excel 2003 および Excel 2002 でオートシェイプに入力されている文字の正しいプロパティ情報が取得できない』
ht tp://support.microsoft.com/kb/959558/ja
１文字置換のケースでは、mhtファイル経由を検討してみてもいいかもしれません。
Sub sample()
Const chk = "赤"
Const rep = "黒"
Dim ws As Worksheet
Dim tmp As String
Dim buf As String
Dim n As Long
'作業用mhtファイル名を設定。 _
同名既存ファイルがあれば上書きするので要注意。
tmp = Application.DefaultFilePath & "\temp.mht"
Set ws = ActiveSheet
ActiveWorkbook.PublishObjects.Add( _
xlSourceSheet, tmp, _
ws.Name, "", _
xlHtmlStatic).Publish True
'作業用mhtファイルOpen。
n = FreeFile
Open tmp For Input As #n
buf = StrConv(InputB(LOF(n), #n), vbUnicode)
Close #n
'---置換作業---
buf = Replace$(buf, chk, rep)
'--------------
'作業ファイル書き込み直してOpen、Copy。
n = FreeFile
Open tmp For Output As #n
Print #n, buf
Close #n
With Workbooks.Open(tmp)
.Sheets(1).Copy ws
.Close False
End With
'作業用mhtファイル削除。
Kill tmp
Set ws = Nothing
End Sub
|
|
n
- 11/9/2(金) 23:32 -
