Option Explicit Sub 対象Word文書の全てのスタイルを取得() Dim 現在のパス As String Dim カウンタ文書 As Integer Dim カウンタstyle As Integer Dim ファイルシステムオブジェクト As Object ' FileSystemObject Dim フォルダ As Object Dim ファイル As Object Dim 開始日時 As Variant Dim 終了日時 As Variant Dim ファイル名 As String Dim スタイル As Object Dim ワード As Word.Application Dim 処理文書 As Word.Document Dim 追加シート名初期 As String Dim 追加シート名 As String Dim 重複 As Integer Dim シート As Worksheet Dim シート数 As Integer Dim 出力行 As Integer 開始日時 = Now ' 開始時刻を変数に格納します。 現在のパス = ThisWorkbook.Path 追加シート名初期 = "スタイル一覧" 追加シート名 = 追加シート名初期 For 重複 = 1 To 100 ' 100枚まで追加しても重複しないように追番を設定します。 For Each シート In Worksheets If シート.Name = 追加シート名 Then 追加シート名 = 追加シート名初期 & "(" & 重複 & ")" End If Next シート Next 重複 シート数 = Worksheets.Count Worksheets("テンプレート").Copy After:=Worksheets(シート数) ActiveSheet.Name = 追加シート名 出力行 = 1 Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject") Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス) Set ワード = CreateObject("Word.Application") '★このマクロのWord 文書の存在するフォルダの全てのファイルを対象 For Each ファイル In フォルダ.Files ファイル名 = ファイル.Path If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "doc" Then If Len(Dir(ファイル名)) <> 0 Then 'ロック用の一時ファイル~$は対象外 'Stop カウンタ文書 = カウンタ文書 + 1 Set 処理文書 = ワード.Documents.Open(Filename:=ファイル名) '文書ファイルを開く カウンタstyle = 0 ThisWorkbook.Worksheets(追加シート名).Activate 出力行 = 出力行 + 1 Range("A1").Cells(出力行, 1).Value = カウンタ文書 Range("B1").Cells(出力行, 1).Value = ファイル名 For Each スタイル In 処理文書.Styles カウンタstyle = カウンタstyle + 1 Range("C1").Cells(出力行, 1).Value = カウンタstyle Range("D1").Cells(出力行, 1).Value = スタイル.NameLocal Range("E1").Cells(出力行, 1).Value = スタイル.Font.Name Range("F1").Cells(出力行, 1).Value = スタイル.Font.Size Range("G1").Cells(出力行, 1).Value = スタイル.Font.Bold Range("H1").Cells(出力行, 1).Value = スタイル.Font.Italic 出力行 = 出力行 + 1 Next 出力行 = 出力行 - 1 処理文書.Close savechanges:=False '保存せずに文書ファイルを閉じる Set 処理文書 = Nothing End If End If Next '★ファイル Set ワード = Nothing Set フォルダ = Nothing Set ファイルシステムオブジェクト = Nothing 終了日時 = Now MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _ & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。" End Sub