エクセルの文字置換マクロで太く赤字にしたい方法

このQ&Aのポイント
  • エクセルの文字置換マクロを使用する際、置換後の文字を太く赤字にする方法を教えてください。
  • ワード置換マクロを使用してエクセルの文字を置換する際、置換後の文字を太く赤字にする方法について教えてください。
  • エクセルのマクロを使って文字を置換する方法について教えてください。特に置換後の文字を太く赤字にする方法が知りたいです。
回答を見る
  • ベストアンサー

置換後に太く赤字にしたいです

めぐみと申します。 以前に兄に以下のマクロを作ってもらいました。 エクセルにある文字を置換してくれるマクロです。 置換後の文字を太く赤字にしたいですがそのようにすればいいでしょうか? 恐れ入りますが知っている方がいらっしゃりましたら教えて頂けないでしょうか? よろしくお願いいたします。 Sub ワード置換() Dim wdObj As New Word.Application Dim buf As String buf = Dir(ActiveWorkbook.Path & "\*.doc") Do While buf <> "" wdObj.Documents.Open ActiveWorkbook.Path & "\" & buf n = 1 Do While ActiveSheet.Cells(n, 1) <> "" fdtxt = ActiveSheet.Cells(n, 1) rptxt = ActiveSheet.Cells(n, 2) With wdObj.Selection.Find .Text = fdtxt .Replacement.Text = rptxt .Forward = True .Wrap = wdFindContinue End With wdObj.Selection.Find.Execute Replace:=wdReplaceAll n = n + 1 Loop buf = Dir() Loop wdObj.Quit End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

Sub ワード置換with書式()  Dim wdObj As New Word.Application  Dim buf As String  dim n as long, fdtxt as string, rptxt as string  buf = Dir(ActiveWorkbook.Path & "\*.doc")  Do While buf <> ""     wdObj.Documents.Open ActiveWorkbook.Path & "\" & buf   wdobj.visible = true  n = 1  Do While ActiveSheet.Cells(n, 1) <> ""   fdtxt = ActiveSheet.Cells(n, 1)   rptxt = ActiveSheet.Cells(n, 2)   wdobj.selection.find.clearformatting   wdobj.selection.find.replacement.clearformatting   wdobj.selection.find.replacement.font.color = vbred   wdobj.selection.find.replacement.font.bold = true  With wdObj.Selection.Find   .Text = fdtxt   .Replacement.Text = rptxt   .Forward = True   .Wrap = wdFindContinue   .format = true  End With   wdObj.Selection.Find.Execute Replace:=wdReplaceAll   n = n + 1  Loop  wdobj.selection.document.save  wdobj.selection.document.close false  buf = Dir()  Loop  wdObj.Quit End Sub 今のエクセルのマクロのブックに記載して実行します。 他のブックに移植すると作動しない恐れがあるので,注意して下さい。 #投稿に先立ってマクロを編集しましたか? せっかく置換しても結果が全く残らないとか,ずいぶん不自然なマクロになっていますが。

megumi19910715
質問者

お礼

早速の返信ありがとうございます。 完璧に動作しました。 素晴らしいマクロを作成して頂きまして本当にありがとうございます。 今後とも何とぞよろしくお願いします。

その他の回答 (1)

  • tsubuyuki
  • ベストアンサー率45% (699/1545)
回答No.2

おそらく、内容についてはあまり理解出来ていないだろうなと思いつつ。 With wdObj.Selection.Find     With .Replacement.Font      ' ここから         .Color = wdColorRed         .Bold = True            End With             ' ここまで4行追加 .Text = fdtxt としてやるとできると思いますよ。 #1さんがおっしゃるように、保存の概念が一切無く、 置換して終了・・なコードですね。 さらに言うと、ワード文書が大きくなると 文書を読み込みしきらないうちに次のコードに進む可能性も見えますので エラー(フリーズ)が発生する確率が上がります。 もう少し練った方がよろしいかと思われます。

関連するQ&A

  • 返ってくる値が違う

    VBAでフォルダの中のファイルの個数を取得するコードなのですが Sub test1() Dim i As Long, buf, Path As String Path = ActiveWorkbook.Path & "\" buf = Dir(Path & "*.*") Do While buf <> "" i = i + 1 buf = Dir() Loop MsgBox "「" & ActiveWorkbook.Path & "」には、全部で" & i & "個のファイルがあります。" End Sub Sub test2() Dim Path As String Dim i As Long, FSO As Object, f As Object Path = ActiveWorkbook.Path & "\" Set FSO = CreateObject("Scripting.FileSystemObject") MsgBox "「" & ActiveWorkbook.Path & "」には、全部で" & FSO.GetFolder(Path).Files.Count & "個のファイルがあります。" Set FSO = Nothing End Sub Test1とtest2では返ってくる値が違うのですが なぜでしょうか? Test2はフォルダの個数も取得されてるのですか?

  • VBAでのDoWhileの中のDoWhile

    VBAでファイル名取得のマクロを作成しているのですが buf = Dir(C\aa\aaa\, vbDirectory) buf= Dir(C:\aa, vbDirectory) Do While buf <> "" Do While bufa <> "" msg = msg & bufa & vbCrLf bufa = Dir() Loop msg = msg & buf & vbCrLf buf = Dir() Loop がうまく動作しません。 Dirの()が空白なのと、Do While <>の中身が空白のどちらかが原因だと思うのですが Do Whileの中でさらに Do Whileを動作させるにはどのように書けばいいのでしょうか?

  • 表を新しいブックに保存

    Sub 表を新しいブックに保存反映日ごと() Application.ScreenUpdating = False Dim フルパス As String, ファイル名 As String, パス As String, 新ファイル名 As String 新ファイル名 = ActiveSheet.Name フルパス = ActiveWorkbook.FullName ファイル名 = Dir(フルパス) 'パスを取得 パス = Replace(フルパス, ファイル名, "") '表の範囲選択をする Range("A1").Select Dim 行数 As Long, 列数 As Long 行数 = 1 列数 = 1 Do While Cells(行数, 1) <> "" 行数 = 行数 + 1 Loop 行数 = 行数 - 1 Do While Cells(1, 列数) <> "" 列数 = 列数 + 1 Loop 列数 = 列数 - 1 Range(Cells(1, 1), Cells(行数, 列数)).Select Selection.Copy '新しいブックを開く Workbooks.Add Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Do While Range("A2") <> "" Range("A1").Select '一番上の発売日の範囲を取得 Range("A2").Select Dim 列 As Long Dim i As Long 列 = 1 '列数を取得 Do While Cells(1, 列) <> "" 列 = 列 + 1 Loop 列 = 列 - 1 '発売日ごとのデータ量を取得 i = 2 Do Until Cells(i, 1) <> Range("A2").Value i = i + 1 Loop i = i - 1 '発売日のまとまりのデータ範囲を選択 Range(Cells(1, 2), Cells(i, 列)).Select '発売日ごとのデータをコピー Selection.Copy '発売日を取得 Dim 発売日 As Long 発売日 = Range("A2").Value '新しいブックを追加してシート名を発売日に設定 Workbooks.Add ActiveSheet.Name = 発売日 新ファイル名 = ActiveSheet.Name Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select 'シート名をファイル名にして保存 ActiveWorkbook.SaveAs Filename:=パス & "メンテ_" & 新ファイル名 & ".xls", _ FileFormat:=xlExcel8, _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWindow.Close Range("A1").Select '保存された発売日分のデータを削除 Range(Cells(2, 1), Cells(i, 列)).Select Selection.Delete Shift:=xlUp Loop '不要になった表転記用ブックを閉じる Application.DisplayAlerts = False ActiveWindow.Close Application.DisplayAlerts = True Range("A1").Select Application.ScreenUpdating = True End Sub Sub 表を新しいブックに保存() Application.ScreenUpdating = False Dim フルパス As String, ファイル名 As String, パス As String, 新ファイル名 As String 新ファイル名 = ActiveSheet.Name フルパス = ActiveWorkbook.FullName ファイル名 = Dir(フルパス) 'パスを取得 パス = Replace(フルパス, ファイル名, "") '表の範囲選択をする Range("A1").Select Dim 行数 As Long, 列数 As Long 行数 = 1 列数 = 1 Do While Cells(行数, 1) <> "" 行数 = 行数 + 1 Loop 行数 = 行数 - 1 Do While Cells(1, 列数) <> "" 列数 = 列数 + 1 Loop 列数 = 列数 - 1 Range(Cells(1, 1), Cells(行数, 列数)).Select Selection.Copy '新しいブックを開く Workbooks.Add Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select 'シート名をファイル名にして保存 ActiveWorkbook.SaveAs Filename:=パス & 新ファイル名 & ".xls", _ FileFormat:=xlExcel8, Password:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWindow.Close Range("A1").Select Application.ScreenUpdating = True End Sub

  • 複数フォルダに格納されたファイル名取得VBA

    お世話になっております。 あるフォルダに複数のフォルダが格納されており、更にそのフォルダの中にあるファイルの情報を取得するプログラムを書いたのですが、実行すると下記のようなエラーとなってしまいます。 ■エラー プロシージャの呼び出し、または引数が不正です 下から3行目、「buf = Dir()」が問題であることはわかるのですが、 何が問題でどのように解決したらいいかわかりません。 どなたかご教授の程よろしくお願い致します(>_<) ------------------------------------------------------------------------ Sub test() Dim buf As String Dim fName As String Dim msg As String buf = Dir("*.*", vbDirectory) Do While buf <> "" If GetAttr(buf) And vbDirectory Then If buf <> "." And buf <> ".." Then fName = Dir(CurDir & "\" & buf & "\" & "*.jpg") Do While fName <> "" cnt = cnt + 1 Cells(cnt, 1) = buf Cells(cnt, 2) = fName msg = msg & buf & "\" & fName & vbCrLf fName = Dir() Loop MsgBox msg End If End If buf = Dir() Loop End Sub ------------------------------------------------------------------------ これが実現できないと細かい作業を毎日繰り返す事となり、 かなり業務不可が高いです。。 繰り返しになってしまいますが、どなたかご回答よろしくお願い致します。

  • 【VBA】 ファイル名の取得

    23歳OLです。 会社でマクロを組んでいるのですが、 できないところがあったのでご相談させてください。 ▼やりたいこと ================================================ ・フォルダを自分で指定して、選択したファイルの名前をシートに書き込む 1.txt 2.log 3.xls とフォルダに入っていたら 1.txt 2.log 3.xls とシートに名前を書き込んでほしいです。 ・ファイルの種類はいろいろある。(txt.logなど) ================================================ ▼現在書いてみたコード ======================== Sub Sample1() Dim buf As String, cnt As Long Const Path As String = "" buf = Dir(Path & "*.*") Do While buf <> "" cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Loop End Sub ======================== これだと、初めから指定したフォルダしか取得することができないらしいです。 そもそもConst Path As String = "このぶぶん" このぶぶんにフォルダを指定しても動きませんでした。? どこが原因なのでしょうか? ご教示お願いします。

  • excelのファイルとセル値を書き出したい

    excel2003を利用しています。 とあるフォルダにある excelファイル名(自分自身のファイルを除く) を全て書き出して、 且つ A1セルの値をB列に書き出すことを、やろうとvbaを作ってみましたが。 最後のファイルのA1セルを書きだすところで、エラーになっていまい そこだけ空白になってしまいます。※写真参照 記述は以下の通りです。どのように修正すればよいか 教えていただけないでしょうか? また他にもっと優れた記述があれば、そちらも教えて欲しいです。 よろしくお願いします。 Sub test() Dim buf As String, cnt As Long Dim Path As String Path = ThisWorkbook.Path & "\" buf = Dir(Path & "*.xls") cnt = 2 Do While buf <> "" If buf <> ThisWorkbook.Name Then cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Workbooks.Open Filename:=Path & "\" & buf MsgBox Workbooks(buf).Worksheets(1).Range("A1").Value Cells(cnt, 2) = Workbooks(buf).Worksheets(1).Range("A1").Value Workbooks(buf).Close End If Loop End Sub

  • フォルダ内にあるファイルを取得したい

    エクセル2010を使用しています。 VBA(マクロ)で以下の作業を実行したいと考えていますが、 初心者につき、ご教示いただけますでしょうか。 「マクロ」ファイルにある「実行」Sheetというにある「実行」ボタンで L2に入力したパス内にあるファイル(.xlsや.xlsmや.xlsbが混在しますが、基本的には全てエクセルファイル)のファイル名を K8から下へ取得したいのですが・・ 参考にしたコードでは うまく動作しませんでした。 以下では、L2のパスを参照するのも組めていないため、コード内に直接パスを書き込んでいますが 実際は、パスを変動させて使いたいので、L2を参照できるようになると助かります。 ※パスは、質問用に仮置きで「パス」としています。 Sub Sample() Dim buf As String, cnt As Long Const Path As String = "パス" buf = Dir(Path & "*.*") Do While buf <> "" cnt = cnt + 8 Cells(cnt, 11) = buf buf = Dir() Loop End Sub また、このコードでは マクロを実行するファイル自体のファイル名も取得してしまうようなので、 自身のファイル名以外のものを取得することは可能でしょうか。 ご指導のほど、よろしくお願い致します。

  • .xlsファイルが存在するパスを表示させたい

    エクセルマクロ初心者です。 .xlsファイルをサブフォルダも含め検索し、A列にファイル名、B列にファイルが存在するパスを表示させるにはどうしたらいいでしょうか?検索するベースのディレクトリは決まっている”C:\temp”のでtemp以下、.xlsがどこに存在するのかを検索するマクロを組もうとしています。 いろんな書き込みを探し、サブフォルダを含め、ファイル名を取得するものは発見できたので組み込んでみましたが、、パスの表示方法がわかりません。 cnt = 0 Call Sample3("C:\temp") Callでサブルーチンsample3に渡し、ファイル名を取得しています。  Dim cnt As Long Sub Sample3(Path As String) Dim buf As String, f As Object buf = Dir(Path & "\*.xls") Do While buf <> "" cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Loop With CreateObject("Scripting.FileSystemObject") For Each f In .GetFolder(Path).SubFolders Call Sample3(f.Path) Next f End With End Sub あとは、どのように書けばいいのでしょうか? 宜しくお願い致します。

  • フォルダ内にあるファイル名を取得するVBA

    エクセル2010を使用しています。 VBA(マクロ)で以下の作業を実行したいと考えていますが、 初心者につき、ご教示いただけますでしょうか。 「マクロ」ファイルにある「実行」Sheetというにある「実行」ボタンで L2に入力したパス内にあるファイル(.xlsや.xlsmや.xlsbが混在しますが、基本的には全てエクセルファイル)のファイル名を K8から下へ取得したいのですが・・ 参考にしたコードでは うまく動作しませんでした。 以下では、L2のパスを参照するのも組めていないため、コード内に直接パスを書き込んでいますが 実際は、パスを変動させて使いたいので、L2を参照できるようになると助かります。 ※パスは、質問用に仮置きで「パス」としています。 Sub Sample() Dim buf As String, cnt As Long Const Path As String = "パス" buf = Dir(Path & "*.*") Do While buf <> "" cnt = cnt + 8 Cells(cnt, 11) = buf buf = Dir() Loop End Sub また、このコードでは 実行ファイル自体のファイル名も取得してしまうようなので、 実行ファイル以外のファイル名を取得したいです。 ご指導のほど、よろしくお願い致します。

  • ExcelのVBAについて

    こんにちは、VBA初心者です。 C:\pictureの中に以下のファイルがあります。 DSC_0134.JPG~DSC_0154.JPG これらのファイルをExcelのA列1~20行に書かれた文字△○%&◎~▲▽%%★に.JPGをつけて保存したくて以下のコードを書きました。 Dim buf As String Dim msg As String Dim i As Integer Dim A As Variant i = 1 buf = Dir("dsc*.jpg", vbNormal) Do While buf <> "" Do While i < 21 buf = Dir() msg = buf 'msg=元の名前 A = Worksheets("sheet1").Cells(i, 1).Value     Worksheets("sheet1").Cells(i, 2).Value = msg          Name "C:\picture\msg" As "C:\picture\A.jpg"     i = i + 1 Loop Loop Name "C:\picture\msg" As "C:\picture\A.jpg"のところで、「ファイルがありません。」となってしまいます。 あと、Worksheets("sheet1").Cells(i, 2).Value = msgのところで、\pictureの中の最初のファイル(DSC_0134.JPG)を表示しません。 どこを直せばよいのでしょうか?

専門家に質問してみよう