Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8884 / 13646 ツリー ←次へ | 前へ→

【30213】オートシェイプ置換後⇒色変えについて けろりん 05/10/21(金) 23:56 質問[未読]
【30245】Re:抽出後のCellの文字色変更と復活 micnak 05/10/24(月) 5:16 回答[未読]
【30545】Re:抽出後のCellの文字色変更と復活 MS−07B 05/10/30(日) 0:50 お礼[未読]

【30213】オートシェイプ置換後⇒色変えについて
質問  けろりん  - 05/10/21(金) 23:56 -

引用なし
パスワード
   はじめまして。
オートシェイプの置換後について質問させていただきます。

フォルダー内のすべてのファイル・シートを
置換したあと、置換した文字のみ青色に変えたいと思っています。
しかし色がどうがんばっても変わってくれず、
行き詰っております

以下にコードを貼らせていただきました(マナー違反なのかもしれませんが・・・)
どなたか優しい方教えていただけないでしょうか?
私の中でやはり
"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

---以上---

インデントそろえてしまっています。すみません。

よろしくお願いいたします。

【30245】Re:抽出後のCellの文字色変更と復活
回答  micnak  - 05/10/24(月) 5:16 -

引用なし
パスワード
   >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

の部分を独立させたプロシージャを作ってみました。
'#####オートシェイプ内の置換処理(置換後⇒青)をする#####
Sub ReplaceAndColorInShape(Target As Shape, strFind As String, strReplace As String)
 
 'テキストを持たないオートシェープなら処理を終了する。
 On Error GoTo TextGetError_
 
 Dim ShapeText As String
 ShapeText = Target.TextFrame.Characters.Text
 On Error GoTo 0
 
 Dim ReplaceResult As String
 ReplaceResult = Replace(ShapeText, strFind, strReplace, 1, -1, vbTextCompare)
 If ReplaceResult <> ShapeText Then
  Target.TextFrame.Characters.Text = ReplaceResult
  Target.DrawingObject.Characters.Font.ColorIndex = 5 '青にする
 End If
 
 Exit Sub

TextGetError_:
End Sub

エラー処理を加えたりしたので元のコードより長くなってしまいましたが、こうやってプロシージャとして独立させてやると以下のようなテストプロシージャを使ったりしながら、動作のおかしい部分に集中してデバッグが出来ます。

'ReplaceAndColorInShapeのテスト用プロシージャ
Sub testReplaceAndColorInShape()
 Dim s As Shape
 For Each s In Sheet1.Shapes
  ReplaceAndColorInShape s, "検索文字列", "置換結果"
 Next
End Sub

【30545】Re:抽出後のCellの文字色変更と復活
お礼  MS−07B  - 05/10/30(日) 0:50 -

引用なし
パスワード
   お返事遅くなってしまって申し訳ありませんでした。

教えていただいた方法を参考に
がんばらさせていただきました。

本当にありがとうございました。

8884 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free