セルの書式を変えずにReplace

Replaceメソッドを使うと
実行後のフォントは、すべて一文字目のフォントになってしまいます。
解決方法は、置換前の書式を保持しておくというもの。


'╂━─━─━─━─━─━─━─━─━─━─━─━─━─━╂

'┃■書式を保持したままReplace

'┃

'┃@param schStr 検索文字列

'┃@param repStr 置換文字列

'╂━─━─━─━─━─━─━─━─━─━─━─━─━─━╂

Sub 書式を保持したままReplace(ByVal schStr As String, ByVal repStr As String)

Dim schCell As Range ' 検索セル

Dim preCell As Range ' 検索セル保持用

Dim i As Long ' セル文字列添え字

Dim strLength As Long ' セル文字列長

' セルを検索する

Set schCell = Sheet2.UsedRange.Find(What:=schStr, LookAt:=xlPart, MatchCase:=False, MatchByte:=False)

' 書式を保持するためのセルを設定(※別シートなど影響のないセルにする)

Set preCell = Sheet1.Range("A1")

Do Until schCell Is Nothing

' 元の書式を保持する

schCell.Copy preCell

' 置換実行

schCell.Replace What:=schStr, Replacement:=repStr, LookAt:=xlPart, MatchCase:=False, MatchByte:=False

' 文字列の長さを取得

strLength = Len(schCell.Value)

' フォントを元に戻す

For i = 1 To strLength Step 1

' フォントカラー

schCell.Characters(i, 1).Font.ColorIndex = preCell.Characters(i, 1).Font.ColorIndex

' schCell.Characters(i, 1).Font.Color = preCell.Characters(i, 1).Font.Color

' 太字

schCell.Characters(i, 1).Font.Bold = preCell.Characters(i, 1).Font.Bold

' フォント

schCell.Characters(i, 1).Font.FontStyle = preCell.Characters(i, 1).Font.FontStyle

' 斜体

schCell.Characters(i, 1).Font.Italic = preCell.Characters(i, 1).Font.Italic

' サイズ

schCell.Characters(i, 1).Font.Size = preCell.Characters(i, 1).Font.Size

' 下線

schCell.Characters(i, 1).Font.Underline = preCell.Characters(i, 1).Font.Underline

' 影

schCell.Characters(i, 1).Font.Shadow = preCell.Characters(i, 1).Font.Shadow

' 取り消し線

schCell.Characters(i, 1).Font.Strikethrough = preCell.Characters(i, 1).Font.Strikethrough

' 上付き

schCell.Characters(i, 1).Font.Subscript = preCell.Characters(i, 1).Font.Subscript

' 下付き

schCell.Characters(i, 1).Font.Superscript = preCell.Characters(i, 1).Font.Superscript

Next i

' 次のセルへ

Set schCell = Sheet2.Cells.FindNext(schCell)

' 書式を保持していたセルをクリア

preCell.Clear

Loop

Set preCell = Nothing

End Sub

以上は、http://blog.livedoor.jp/vba_performance/archives/3402128.htmlから引用しました。とても勉強になりました。

コメントを残す

メールアドレスが公開されることはありません。