| |
はじめまして。
オートシェイプの置換後について質問させていただきます。
フォルダー内のすべてのファイル・シートを
置換したあと、置換した文字のみ青色に変えたいと思っています。
しかし色がどうがんばっても変わってくれず、
行き詰っております
以下にコードを貼らせていただきました(マナー違反なのかもしれませんが・・・)
どなたか優しい方教えていただけないでしょうか？
私の中でやはり
"oTBox.DrawingObject.Characters.Font.ColorIndex = 5 '青にする"
↑の部分が違うと思っております
---コード---
'*指定したフォルダーに入っている"*.xls"ファイルのセル内･オートシェイプ内の一括置換
Sub フォルダ内一括処理()
'#####変数宣言#####
Dim i As Integer
Dim j As Integer
Dim strWk As String
Dim strFind As String
Dim oTBox As Shape
Dim ows As Worksheet
'#####エラー時処理続行#####
On Error Resume Next
'#####フォルダーを選択させExcelのファイルがあるかチェックする#####
Call Get_FldName
'#####置き換える文字の指定#####
strFind = InputBox("置換前の文字を入力してください｡", "一括置換")
If strFind = "" Then End 'キャンセルの時は処理を抜ける
strRep = InputBox("置換後の文字を入力してください｡", "一括置換")
If strRep = "" Then End 'キャンセルの時は処理を抜ける
'#####ファイルがなくなるまで繰り返す#####
If (myBook <> ActiveWorkbook.Name) Then
Do While Filename <> "" 'ファイル名がなくなるまで処理
Workbooks.Open (FolderName & "\" & Filename)
'#####シート数分繰返す#####
For j = 1 To Sheets.Count
'#####セル内の置換処理をする#####
For Each ows In Excel.ActiveWorkbook.Worksheets
Cells.Replace what:=strFind, Replacement:=strRep, lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'#####置換後の文字に色をつける#####
Call PaintTargetCharacter
'#####オートシェイプ内の置換処理(置換後⇒青)をする#####
For Each oTBox In ows.Shapes
ows.Activate
oTBox.Select
strWk = Replace(Selection.Characters.Text, _
strFind, strRep, 1, -1, vbTextCompare)
If strWk = strRep Then
oTBox.DrawingObject.Characters.Font.ColorIndex = 5 '青にする
End If
Range("A1").Select
Next
Next
Next
i = i + 1
'#####開いていたブックの保存#####
Sheets("sheet1").Activate '「sheet1」のシートをアクティブにする
ActiveSheet.Range("A1").Select 'A1をセレクト
ActiveWorkbook.Save
Workbooks(Filename).Close
Application.DisplayAlerts = False
Filename = Dir() '次のファイルへ
Loop
'####ファイルがなくなり次第終了#####
If Filename = "" Then
MsgBox " 終了しました"
End If
Application.ScreenUpdating = True
End If
End Sub
'*フォルダーを選択させパスを取得
Sub Get_FldName()
'#####画面制御#####
Application.ScreenUpdating = False
'#####エラー時処理続行#####
On Error Resume Next
'#####ファイルオープン#####
Set ShellApp = CreateObject("Shell.Application")
Set FName = ShellApp.BrowseForFolder(0, "フォルダ選択", 1) 'フォルダ選択ダイアログの表示
FolderName = FName.Items.Item.Path
'#####キャンセル時終了#####
If FName = "" Then End
'#####対象フォルダー表示#####
Filename = Dir(FolderName & "\*.xls", vbNormal)
MsgBox FolderName, vbOKOnly, "一括処理対象フォルダー"
If Filename = "" Then
MsgBox "Excelファイルがありません。"
Exit Sub
End If
End Sub
'*置換した文字(セル内)に色をつける
Sub PaintTargetCharacter()
'#####変数宣言#####
Dim Target As String
Dim Addr As String
Dim FoundCell As Range
Dim SearchArea As Range
Target = strRep
Set SearchArea = ActiveSheet.UsedRange '検索対象範囲
Set FoundCell = SearchArea.Find(what:=Target) '置換した文字の検索実行
If FoundCell Is Nothing Then Exit Sub '置換文字列が含まれるセルがない場合処理を抜ける
Addr = FoundCell.Address '最初の検索結果のアドレスを格納
'#####検索した文字列の文字色変更#####
Do
Call PaintCh(FoundCell, Target) '対象文字の操作のためプロシージャ呼び出し
Set FoundCell = SearchArea.FindNext(after:=FoundCell)
Loop While FoundCell.Address <> Addr And Not FoundCell Is Nothing
End Sub
Sub PaintCh(FoundCell As Range, Target As String)
'#####変数宣言#####
Dim StartPos As Integer
'#####文字色変更#####
StartPos = InStr(1, FoundCell.Value, Target, vbTextCompare)
With FoundCell.Characters(StartPos, Len(Target)).Font
.Color = vbBlue
End With
End Sub
---以上---
インデントそろえてしまっています。すみません。
よろしくお願いいたします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
