文字を下付にするマクロを教えて

質問

やりたいことは、マクロの中で ExcelファイルとWordファイルの行き来です。
具体的には、Word文章で文字の下付を走らせたいです。
Excelのシート「条件設定2」に下付けしたい文字を入力しておき、そのデータを読みとってWord文章で下付したいです。

マクロのイメージは次のように考えています。

　 Windows("マクロ集").Activate
　 Sheets("条件設定2").Select
対象文字 = Cells(17,12)　 …… L17セルの 「TiO2」
下付文字 = Cells(17,13)　　 …… M17セルの 「2」
　 Set 対象ファイル = GetObject(, "Word.Application")
Windows(対象ファイル).Activate　　　
上記の「対象文字」、「下付文字」データでWord文章の文字下付を行う。

回答No.6

Wendy02

こんにちは。

>このシステムのお礼の仕方を知らないのですがどうすればよいのでしょうか？

解決すれは、どのようにしても構いませんが、しばらく様子を見た上で、締めていただいたほうがよろしいかと思います。私としては、お礼は、点が付くことではなくて、「解決しました」という言葉が、一番のお礼なのですね。なお、今回、GetObject による呼び出しは、多少、特殊な方法かもしれません。

回答No.5

Wendy02

こんばんは。

このように修正してみて、様子を見てください。

#3のコードのSub プロシージャの下の方です。

修正前
------------------------------
　　　　　End With
　　　　　　If Not rngContent Is Nothing Then　'*
　　　　　　　　''intCount = intCount + 1　
　　　　　　　　Set myRange = rngContent
　　　　　　　　With myRange
　　　　　　　　　　MakeSubscript myRange
　　　　　　　　End With
　　　　　　End If
　　　　　　flgFnd = rngContent.Find.Found　'**

　　　　Loop
　　　　mySearch = ""
　　Next
------------------------------

修正後 （特に、*, ** は必要ありません。単なる目印です)

　　　　　　End With
　　　　　　flgFnd = rngContent.Find.Found　 '*
　　　　　　If flgFnd Then　　　　　　　　　 '*
　　　　　　　　'intCount = intCount + 1
　　　　　　　　Set myRange = rngContent
　　　　　　　　With myRange
　　　　　　　　　　MakeSubscript myRange
　　　　　　　　End With
　　　　　　End If
　　　　　　　　　　　　　　　　　　　　　　　 '**
　　　　Loop
　　　　mySearch = ""
　　Next

お礼

夜遅くまで付き合ってもらってありがとうございました。
完璧だと思います。
このシステムのお礼の仕方を知らないのですがどうすればよいのでしょうか？

回答No.4

Wendy02

こんばんは。

>すいません。化学式ではない数字まで全部下付きになってしまうのですが。修正できますか？

やはりなりましたか。カウントを入れて調べてみましたが、そのようになる時と、ならないときがあります。はっきり理由は分かりませんが、何度かしている中で、誤動作するようですので、これは、もう一度、チェックします。しばらくおまちください。

回答No.3

Wendy02

こんにちは。

>H2SO4
>M17セルに「2」N17セルに「4」といった具合です。

もしかして、下付き字を含む文字列は、化学記号ではありませんか？
H2SO4の文字列たけ登録してあれば、数字はいらないように思います。今回は、数字は検出して、下付き文字にしています。

アルファベットに隣り合った数字は、下付き文字ではないでしょうか。

Word マクロ（標準モジュール)
'-----------------------------------------------------

Sub ChemicalLetterCorrect()
　　Dim myRange As Range
　　Dim mySearch As Variant
　　Dim flgFnd As Boolean
　　Dim rngContent As Range
　　Dim intCount As Long
　　Dim objBk As Object
　　Dim xlSht As Object
　　Dim arSrchdata As Variant

　　'Excelのブック名（要パス名)
　　Const xlNAME As String = "D\:マクロ集.xls"
　　On Error GoTo ErrHandler

　　Set objBk = GetObject(xlNAME, "EXCEL.Sheet")
　　'シート名
　　Set xlSht = objBk.Worksheets("設定条件2")
　　With xlSht
　　　　'化学名リスト
　　　　arSrchdata = .Range("L17", .Range("L1000").End(-4162)).Value
　　　　arSrchdata = xlSht.Application.Transpose(arSrchdata)
　　End With
　　If UBound(arSrchdata) = 0 Then
　　　　GoTo ErrHandler
　　End If
　　For Each mySearch In arSrchdata

　　　　flgFnd = True '初期値
　　　　Set rngContent = ActiveDocument.Content

　　　　Do While flgFnd = True
　　　　　　With rngContent.Find
　　　　　　　　.ClearFormatting
　　　　　　　　.Text = mySearch
　　　　　　　　.Wrap = wdFindStop
　　　　　　　　.Format = False
　　　　　　　　.MatchCase = False
　　　　　　　　.MatchWholeWord = False
　　　　　　　　.MatchWildcards = False
　　　　　　　　.MatchFuzzy = False
　　　　　　　　.Execute
　　　　　　End With
　　　　　　If Not rngContent Is Nothing Then
　　　　　　　　''intCount = intCount + 1　
　　　　　　　　Set myRange = rngContent
　　　　　　　　With myRange
　　　　　　　　　　MakeSubscript myRange
　　　　　　　　End With
　　　　　　End If
　　　　　　flgFnd = rngContent.Find.Found

　　　　Loop
　　　　mySearch = ""
　　Next
　　'MsgBox "終了しました。"　''"intCount & "個を処理しました。"
ErrHandler:
　　If Err.Number > 0 Then
　　　　MsgBox Err.Number & ": " & Err.Description
　　End If
　　Set xlSht = Nothing
　　Set objBk = Nothing
　　Set myRange = Nothing
　　Set rngContent =　Nothing
End Sub

Function MakeSubscript(rng As Range)
Dim n As Variant
Dim i As Long
Const FLG As Boolean = True　'True で、下付き変更
On Error Resume Next
　For i = 1 To Len(rng.Text)
　If IsNumeric(Mid(rng.Text, i, 1)) Then
　　 With rng.Characters(i).Font
　　　　.Subscript = FLG
　　End With
　End If
　Next
On Error GoTo 0
End Function

'-----------------------------------------------------

p.s. intCount で数をカウントすることを考えてみましたが、ダブってしまうので、正確な数が出ません。

お礼

どうもありがとうございました。
ほぼ希望どおりにマクロを動かすことができました。
感謝です。

補足

すいません。化学式ではない数字まで全部下付きになってしまうのですが。修正できますか？

回答No.2

Wendy02

こんにちは。

マクロのイメージと言うぐらいでしたら、ある程度、自分でコードを書いてほしいと思います。キーワードとして、そのコードの内容を指定してくると、とてもやりにくいし、回答者の能力を試されているように感じてしまいます。

質問の内容というのは、Excelのシートに書いておいた、対象文字列と、下付き文字のリストを読み込んで、そこで、開いているWord文書全体の該当する文字列の中の一部を下付き文字にしたいということではないでしょうか。

もし、そうなら、内容的にみて、Wordのマクロではないでしょうか。Excelからというのは、多少ともつらい部分があるように思います。GetObject にしているというのは、それなりの理由を出してもらわないと、納得できません。エラーの発生する可能性もあります。

Wordのマクロの質問は、多くは、Excelマクロを知っているからできるというような、単純な質問でないものも多いのですが、中には、単純な内容で満足され、せっかく書いたこちらのコードを無にする方もいらっしゃれば、Wordのマクロだと主張されるのに、何度も書いて、あげくは、イメージとは違うとダメ押しされて、内容を良く確認すると、Wordのマクロではできないものもあるので、私は、安易に解答するのは控えるようにしています。

基本的なことですが、Wordのマクロは、Normal.dot に書くわけで、自動的に参照設定するので、一旦、マクロを登録すれば、Wordの中で共通に動きます。別に、意図的にWordのドキュメント自体に入れなければ、個々のドキュメントにマクロが入るわけではありません。

また、
>　 Set 対象ファイル = GetObject(, "Word.Application")

「対象ファイル（オブジェクト)」にするのなら、その部分は、Word.Application ではないはずです。Word.Application なら、「対象ファイル」を新たに取得しなくてはなりません。単に、ActiveDocument ではないでしょうか。

Excelのシート側は、
対象文字 = Cells(17,12)　 …… L17セルの 「TiO2」
下付文字 = Cells(17,13)　　 …… M17セルの 「2」
それにひとつだけなのでしょうか。後になって、セルは他にも書いてあります、ということになるのではないでしょうか。実務的に考えれば、WordのひとつのドキュメントのTableに作っても同じことだと思います。

補足

丁寧な回答ありがとうございます。
マクロはWordのマクロでも構いません。
対象文字はL17セルから下へ複数続きます。
下付文字もM17から右に複数続きます。
例えばL17セルに「H2SO4」
M17セルに「2」N17セルに「4」といった具合です。
よろしくお願いします。

回答No.1

xls88

Microsoft Word *.* Object Libraryを参照設定する。

Dim wdObj As Object
Dim txt As String
Dim n As Integer

txt = Sheets("条件設定2").Cells(17, 12).Value
n = Len(txt)
Set wdObj = GetObject(, "Word.Application")
wdObj.Activate
'文末に追記
wdObj.ActiveDocument.Content.InsertAfter txt
With wdObj.Selection
.MoveRight Unit:=wdCharacter, Count:=n, Extend:=wdExtend
wdObj.ActiveDocument.Range(.Start + n - 1, .Start + n).Font.Subscript = True
End With
Set wdObj = Nothing