【WORD2007 VBA】オープンしているWORDファイルで使用されているフォント名とサイズを全て一覧表示するVBA

このQ&Aのポイント
  • オープンしているWORDファイルで使用されているフォント名とサイズを全て一覧表示するVBAの作成方法について教えてください。
  • n-junさんからの回答で、サンプルを作成しテストしたところWORD2007で希望通りの結果が得られましたが、大きなWORDファイルに適用したところ結果が表示されない問題が発生しています。エラーメッセージも表示されないため、解決方法を教えていただきたいです。
  • 実際にWORD2002で検証してみましたが、問題なく動作しました。
回答を見る
  • ベストアンサー

WORD2007 VBA

オープンしているWORDファイルで使用されているフォント名とサイズを全て一覧表示するVBAを希望しています。 次のような表示が欲しいのですが、よろしくお願いします。 MSP ゴシック 10 MSP ゴシック 12 Arial 14 Times New Roman 10 ---------------------------- この質問に対してn-jun さんより以下のご回答を頂きました。サンプルを作りテストしたところWOOD2007で希望通りの結果が得られましたのでベストアンサーとさせてもらいました。 しかし、その後大きなWORDファイルに適用したところ、結果が表示されません。 エラーがでれば問題解決につながるのでしょうが、何らエラーメッセージが出ません。 ご指導いただければありがたいです。 -------------------------------- Word2002で検証しました。。。 Sub try() Dim myDic As Object Dim v, vv Dim i As Integer Set myDic = CreateObject("Scripting.Dictionary") i = 0 ReDim vv(i) For Each v In ActiveDocument.Range.Characters If Len(v) > 0 Then If Not myDic.Exists(v.Font.Name & " " & v.Font.Size) Then myDic(v.Font.Name & " " & v.Font.Size) = "" vv(i) = v.Font.Name & " " & v.Font.Size i = i + 1: ReDim Preserve vv(i) End If End If Next MsgBox Join(vv, vbCrLf) Set myDic = Nothing End Sub

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

  • ベストアンサー
  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.2

No.1です。 WordVBAは殆どやったことはないのですが、 Excelなんかでもデータ数が増えてくると 動きが悪くなるケースもあります。 今回のコードは1文字ずつチェックしていくため ページ数増加による文字数が増えているのが 影響してくるのではないかと思われます。 エラーが出ていないとの事ですから Dim i As Integer を Dim i As Long に変更するとかも違うでしょうし。。。。 ファイルを分割して調べるなどしかないのかな?

oldhidesan
質問者

お礼

Integer から Longに変えてみましたが、結果は表示されませんでした。 色々お世話になりました。

その他の回答 (1)

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.1

例えば大きなワードファイルの半分とかならどうなのかとか、 大きなワードファイルはコードを記載したものとは 別のドキュメントなのかとか、 色々条件になる部分がありそうですけど・・・ 例えばコードを記載したものとは 別のドキュメントであれば、 For Each v In ActiveDocument.Range.Characters を For Each v In Documents("abc.doc").Range.Characters (adc.docと言うドキュメントで既に開いている場合) にしてみるとかかな? あとはその大きなワードファイルが 本当に大きすぎるとかなら、 そのファイルで検証しないと難しいかも。

oldhidesan
質問者

補足

n-jun さん ご返事ありがとうございます。 最後のファイル名を入れる方法は試しましたが、今までと変わりませんでした。 テストしたファイルは91ページのA4ファイルです。 10ページまでのファイル、20ぺージまでのファイル、30ページまでのファイル、40ページまでのファイルは正しく結果が表示されました。しかし、50ページまでのファイルで結果表示が出なくなりました。 上記のファイルは殆どが表の構成になっており、その中には200ほどの図が入っており、また多くのハイパーリンクが設定されております。 ファイルが大きくなるだけで結果が違うようなことがVBAでは良くあることなのでしょうか?

関連するQ&A

  • WORD2007 VBA

    オープンしているWORDファイルで使用されているフォント名とサイズを全て一覧表示するVBAを希望しています。 次のような表示が欲しいのですが、よろしくお願いします。 MSP ゴシック 10 MSP ゴシック 12 Arial 14 Times New Roman 10

  • ワード2000のVBAについて

    ワード2000を使っています。 VBAで、ダイアログボックスを開き、指定したファイルのファイル名をフルパスで取得したいのですが、下記のコードでは、ファイル名しか取得できません。 どのようにしたら、フルパスを取得できるのでしょうか? たびたびすみませんが、誰か教えてください。 Dim Name With Dialogs(wdDialogFileOpen) If .Display = -1 Then Name = .Name End If End With MsgBox ("ファイル名は" & Name & "です。")

  • エクセルVBAで重複入力の排除

    すでに入力規則はリストで使用しております。 そのためVBAで重複入力の排除を行おうと思います。 一応以下のコードでできたのですが、もっと良い方法があったら教えてください。 お願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range)    Dim myDic As Object    Dim c As Variant, varData As Variant    Dim i As Long    If Application.Intersect(Target, Range("A1:A50")) Is Nothing Then Exit Sub    Set myDic = CreateObject("Scripting.Dictionary")    varData = Range("A1:A50").Value    For Each c In varData      If Not c = Empty Then        i = i + 1        If Not myDic.Exists(c) Then          myDic.Add c, Null        End If      End If    Next    If myDic.Count < i Then     MsgBox Target & " は重複!"     Application.EnableEvents = False     Application.Undo     Application.EnableEvents = True    End If End Sub

  • エクセルVBAでDictionaryオブジェクトについて

    エクセル2000です。 教えてください。 http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html というサイトで  「myDic.Add Cells(i, 1).Value, Cells(i, 2).Value は   myDic(Cells(i, 1).Value) = Cells(i, 2).Value と書くこともできます。 」 という記述を見つけました。 試してみたところ Sub test01() Dim myDic As Object Dim myAr() Set myDic = CreateObject("Scripting.Dictionary") For i = 2 To 7 If Not myDic.exists(Cells(i, 1).Value) Then myDic.Add Cells(i, 1).Value, Cells(i, 2).Value End If Next i myAr() = myDic.Keys MsgBox Join(myAr()) End Sub Sub test02() Dim myDic As Object Dim myAr() Set myDic = CreateObject("Scripting.Dictionary") For i = 2 To 7 myDic(Cells(i, 1).Value) = Cells(i, 2).Value Next i myAr() = myDic.Keys MsgBox Join(myAr()) End Sub 上記2つのマクロは、Keyに関してはまったく同じ働きをするようです。 ところがItemに関しては、Keyが重複した場合、あとから出てきた方に上書きされるようです。 これはtest01では、Keyの重複を排除しているためItemは最初に出たものが残る、test02は重複の場合、無条件でKeyが上書きされ(ても値は変化しないけど)、したがってItemも上書きされるという理解でよろしいのでしょうか? ならば、Itemを気にしない場合、わざわざ If Not myDic.exists(Cells(i, 1).Value) Then myDic.Add Cells(i, 1).Value, Cells(i, 2).Value End If と、3行も費やして重複のチェックをしなくとも myDic(Cells(i, 1).Value) = Cells(i, 2).Value のわずか一行で済むということですよね?

  • VBA スケジュール表作成_連想配列で祝日設定

    Win10でExcelは2016を使用しています。 「西暦」をMsgBoxで指定し、スケジュール表を作成するマクロを作成中です。 日曜と祝日のセルをグレー&赤文字にさせたいので、別シートに祝日を表にしそれを連想配列に記憶させて、祝日も赤文字にさせたいのですが、下記のマクロですと祝日の曜日のセルをグレー&赤文字に出来ず行き詰っています。 ------ Sub スケジュール_日_祝_休ver() Dim ws1 As Worksheet Dim myDic As Object Dim buf As String Dim i As Integer Dim Keys() As Variant Dim ws2 As Worksheet 'シート Dim ye As Integer '年 Dim mo As Integer '月 Dim dy As Integer '日 Dim dLast As Integer '最終日 Dim r As Integer '日付書き込み列 Set myDic = CreateObject("Scripting.Dictionary") Set ws1 = Worksheets("祝日") maxRow = ws1.Range("C65536").End(xlUp).Row For i = 2 To maxRow buf = ws1.Cells(i, 3).Value 'C列のセルの値をbufに格納する If buf = "" Then '空白セルではなく ElseIf Not myDic.Exists(buf) Then '辞書にまだ登録されていなければ myDic.Add buf, 1 'そのセルの値を連想配列に登録する。 End If Next i ye = Application.InputBox("西暦を入れて下さい", Type:=1) Set ws2 = Worksheets("白紙") With ws2 r = 2 '当年1~12月 '1日の列に月を表示 For mo = 1 To 12 If mo = 1 Then .Cells(1, r) = "’" & ye & "年" & mo & "月" .Cells(1, r).Font.Bold = True .Cells(1, r).Font.Name = "HGP創英角ゴシックUB" .Cells(1, r).Font.Size = 20 Else .Cells(1, r) = mo & "月" .Cells(1, r).Font.Bold = True .Cells(1, r).Font.Name = "HGP創英角ゴシックUB" .Cells(1, r).Font.Size = 20 End If '最終日取得 dLast = Day(DateSerial(ye, mo + 1, 0)) '日にちと曜日を入れ、日・祝 のセルをグレー&赤文字 For dy = 1 To dLast .Cells(3, r) = ye & "/" & mo & "/" & dy .Cells(3, r).NumberFormatLocal = "d" .Cells(4, r) = WeekdayName(Weekday(.Cells(3, r).Value), True) Key = .Cells(3, r).Value If .Cells(4, r).Value = "日" Or .Cells(3, r).Value = myDic.Item(Key) Then '日と祝日 .Cells(4, r).Font.ColorIndex = 3 ws2.Range(Cells(5, r), Cells(73, r)).Select With Selection.Interior .ColorIndex = 15 End With End If r = r + 1 Next dy '月変わりに縦太線を引く .Range(Cells(1, r - 1), Cells(73, r - 1)).Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With Next mo End With End Sub ------- 原因をさぐるべくF8で確認しながら進めたところ、 「If .Cells(4, r).Value = "日" Or .Cells(3, r).Value = myDic.Item(Key) Then 」 のところで、.Cells(3, r).Value は「2020/1/1/」でmyDic.Item(Key)は「2020/01/01/」になっていました。 やはり、これですと同じとは認識されないのでしょうか? でも、月日が2ケタの祝日のセルをグレー&赤文字にならず、他の原因のような気もします... -- どなたかご教示頂けましたら有難いです。 よろしくお願い致します。

  • Excel VBAでCheckboxの名前を変数にとって値を調べたい

    Excel VBAでCheckboxの名前を変数にとって値を調べたいのです. シートにCheckboxがたくさん貼ってあり名前とOn,Offを調べたいのですが下記では名前は調べられてもOn,Offが確認できないのですが On,Offを別変数にとる場合タイプはなににすればいいでしょうか。 たとえば dim i as integer dim checkname() dim checvalue() as ???? i=0 for i=1 to 2 If Mid(ActiveSheet.Shapes(i).Name, 1, 5) = "Check" Then i=i+1 redim preserve checkname(i) checkname(i)=ActiveSheet.Shapes(i).Name redim preserve checvalue(i) checvalue(i)=ActiveSheet.Shapes(i).value <---これではエラー end if next i

  • WORD VBAでハイパーリンクの文字列色変更

    VBAの初心者です。教えてください。 色々なWEBサイトより情報を集めてWORD文書を作成しています。フォント名、サイズ、色がバラバラで、それを統一するVBAは以下のように出来たのですが、ハイパーリンクされている文字の色も黒になっています。ハイパーリンクされている文字色だけは本来の青色で表示したいのですが、どのようにしたらいいのか分かりません。よろしくお願いします。 (WORD2007 Windows7) Sub フォント変換() ' ' With ActiveDocument.Content.Find .Text = MatchiWildcards .Format = True .Font.Size = 11 With .Replacement .Font.Name = "MS Pゴシック" .Font.Size = 10.5 .Font.Color = wdColorBlack .Font.Bold = False End With .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .Text = MatchiWildcards .Format = True .Font.Size = 12 With .Replacement .Font.Name = "MS Pゴシック" .Font.Size = 10.5 .Font.Color = wdColorBlack .Font.Bold = False End With .Execute Replace:=wdReplaceAll End With End Sub

  • wordの目次のフォント

    こんにちわ。 word2000で目次を作ってフォントを標準(MSPゴシック)から変更(MSゴシック)したのですが,"フィールドの更新"をすると,フォントが標準(MSPゴシック)に戻ってしまいます。 変更したフォントの設定(MSゴシック)を残すにはどうすればよいでしょうか? 教えてください。お願いします。

  • エクセルVBAで場所の指定

    また質問させていただきます。先日Wendy02さんに以下のコードを お教えいただきました。 少し内容を変更したくまた質問をさせていただきます。 移動前のフォルダ名をあらかじめフルパスで指定してある セルがあるのですが、そのセルには C:\Documents and Settings\user\デスクトップ\Test1Fold とあるとして、そのパスを取得して SourceDir = SourceFolder & "Test1Fold\" '末尾に\ は付けなくてよい の部分は移動前のフォルダが変わっても対応できるようにしたいのですが、どのようにするのかわかりません。どのように記述すればいいでしょうか?よろしくお願いします。 Sub MoveDirectries()   Dim SourceFolder As String   Dim SourceDir As String   Dim DestFolder As String   Dim DestDir As String   Dim ArDirs() As String   Dim FOLname As String   Dim i As Integer   Dim v As Variant   Dim ret As Integer      'Win 2000以上   Const MYCMD1 As String = "CMD /C MOVE " '末尾は半角スペースを開ける      SourceFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ(元)\ は必ず付ける   DestFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ(先)\ は必ず付ける      SourceDir = SourceFolder & "Test1Fold\" '末尾に\ は付けなくてよい   DestDir = DestFolder & "Test1AFold\"      '最終フォルダに \ があったら省く   If Right(SourceDir, 1) = "\" Then SourceDir = Mid$(SourceDir, 1, Len(SourceDir) - 1)   If Right(DestDir, 1) = "\" Then DestDir = Mid$(DestDir, 1, Len(DestDir) - 1)      ReDim Preserve ArDirs(i)   FOLname = Dir(SourceDir & "\", vbDirectory)   Do While FOLname <> ""     If FOLname <> "." And FOLname <> ".." Then       If (GetAttr(SourceDir & "\" & FOLname) And vbDirectory) = vbDirectory Then         ReDim Preserve ArDirs(i)         ArDirs(i) = FOLname         i = i + 1       End If     End If     FOLname = Dir   Loop   'フォルダの下のフォルダを作るのは一回のみ   For Each v In ArDirs()     If Dir(DestDir & "\" & v, vbDirectory) = "" Then      ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & """")           ElseIf Dir(DestDir & "\" & v & "\" & v, vbDirectory) = "" Then       ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & "\" & v & """")     End If   Next v End Sub

  • エクセルVBA

    エクセル2003です 勉強中です 教えてください Sheet1     A      B      C       D      1   日付    種類    数量1    数量2  2   2月3日    C      300        10   3   2月4日     B      200       5 4   2月5日     A     100       20 5   2月3日     A     100       10 6   2月4日     B     200       5 7   2月5日     C     300       20 8   2月3日      A      300       20 9   2月4日     C      200        5 10  2月5日     B     100       10 Sheet1     F      G      H       I      1   日付    種類    数量1    数量2  2   2月3日    A      400          3   2月3日     C      300       4   2月4日     B     600       5   2月5日     A     100       6   2月5日     C     400       7 したい事 *A列~D列のデータをF列からI列へ複数条件の集計をしたいのですが *A列~D列の数値が変動すると勝手に自動で集計をして欲しい(シートがアクティブでなくても) *下記コードでC列までの集計ができますがD列の集計がわかりません  (増やそうとすると頭の中がぐちゃぐちゃになって・・・) *前回の集計が残ってしまう Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3 Dim i As Long Range("F2", Range("I" & Rows.Count).End(xlUp)).ClearContents Range("F1:I1").Value = Range("A1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") ' データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value ' myDicへデータを格納 For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) If Not myVal2 = "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next 'Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") Cells(i + 2, 6).Value = myVal3(0) Cells(i + 2, 7).Value = myVal3(1) Cells(i + 2, 8).Value = myItem(i) Next Set myDic = Nothing '並べ替え Range("F2", Range("H" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("F2"), Order1:=xlAscending, _ Key2:=Range("G2"), Order2:=xlAscending, _ Header:=xlGuess End Sub 頭のなかがこんがらがってしまいます お願いです 出来れば説明付きで教えていただけませんか よろしくお願いします