Word見出し一覧作成(VBA)

Wordの見出し一覧を作成するVBAマクロを備忘録として残しておきます。

テスト用Wordファイル

見出し一覧作成Excelマクロ(VBA)

Option Explicit
Option Compare Text

Dim varArrayR0100() As Variant
Dim varArrayR0150() As Variant
Dim varArrayR0200() As Variant

Dim varResultR0100 As Variant
Dim varResultR0150 As Variant
Dim varResultR0200 As Variant

''''''''''''''''''''''''''''
'MAIN
''''''''''''''''''''''''''''
Sub CreateTableMain()
  Worksheets("ResultList").Cells(1, 2).Value = "処理開始"
  Worksheets("ResultList").Cells(2, 9).Value = "処理開始日時："
  Worksheets("ResultList").Cells(2, 10).Value = Now
  Worksheets("ResultList").Cells(3, 9).Value = "処理終了日時："
  Worksheets("ResultList").Cells(3, 10).Value = ""

  varArrayR0100 = Array("4.1.1", "5.1.1", "6.1.1")
  varArrayR0150 = Array("4.1.2", "5.1.2", "6.1.2")
  varArrayR0200 = Array("4.2.1", "4.2.2", "5.2.1", "5.2.2", "6.2.1", "6.2.2")

  Worksheets("ResultList").Range(Cells(1, 4), Cells(1, 10)).ClearContents
  Worksheets("ResultList").Range(Cells(5, 1), Cells(9999, 30)).ClearContents
  

  Dim fileName As String
  Dim fileAllcnt As Integer
  fileAllcnt = GetDocFileList
  
  Dim refRowCnt As Integer
  refRowCnt = 1
  
  Worksheets("DocFileList").Activate
  fileName = Worksheets("DocFileList").Cells(refRowCnt, 1).Value
  
  Dim writeRowPos As Integer
  writeRowPos = 5

  Worksheets("ResultList").Cells(2, 4).Value = "ファイル処理数："
  Worksheets("ResultList").Cells(2, 5).Value = 0
  Worksheets("ResultList").Cells(2, 6).Value = "/"
  Worksheets("ResultList").Cells(2, 7).Value = fileAllcnt

  Do While Trim(fileName) <> ""
    Worksheets("ResultList").Cells(2, 5).Value = refRowCnt
    writeRowPos = GetFileInfo(fileName, writeRowPos)
    
    refRowCnt = refRowCnt + 1
    fileName = Worksheets("DocFileList").Cells(refRowCnt, 1).Value
  Loop

  Worksheets("ResultList").Activate
  Worksheets("ResultList").Cells(1, 2).Value = "処理完了"
  Worksheets("ResultList").Range(Cells(1, 4), Cells(1, 8)).ClearContents
  Worksheets("ResultList").Range(Cells(2, 1), Cells(3, 8)).ClearContents
  Worksheets("ResultList").Cells(3, 10).Value = Now

End Sub

Function GetDocFileList() As Integer
  Dim varArray() As Variant
  Dim varResult As Variant
  Dim buf As String
  Dim cnt As Long
  
  varArray = Array("04", "05", "06")
  
  buf = Dir(ThisWorkbook.Path & "\*docx")
  
  Worksheets("DocFileList").Activate
  Worksheets("DocFileList").Range(Cells(1, 1), Cells(999, 1)).ClearContents
  cnt = 0

  Dim docNum As String
  
  Do While buf <> ""
    docNum = Left(buf, 2)
    
    varResult = Filter(varArray, docNum)
    
    If UBound(varResult) <> -1 Then
      cnt = cnt + 1
      Cells(cnt, 1) = buf
    End If
    buf = Dir()
  Loop
  GetDocFileList = cnt

End Function


Function GetFileInfo(fileName As String, writeRowPos As Integer) As Integer
  Dim fileNameKey As String
  
  Dim wdApp As Word.Application
  Set wdApp = CreateObject("Word.Application")
  wdApp.Visible = True
  
  Worksheets("ResultList").Activate
  fileNameKey = Left(fileName, 2)
  
  Dim wdDoc As Word.Document
  Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\" & fileName, False, True)
  wdDoc.Activate
  
  Dim pageCnt As Integer
  
  With wdDoc
    pageCnt = .Content.Information(wdNumberOfPagesInDocument)
    Worksheets("ResultList").Cells(1, 2).Value = "処理中..."
    Worksheets("ResultList").Cells(1, 4).Value = "ファイル名："
    Worksheets("ResultList").Cells(1, 5).Value = fileName
    
    Worksheets("ResultList").Cells(3, 4).Value = "段落処理数："
    Worksheets("ResultList").Cells(3, 5).Value = 0
    Worksheets("ResultList").Cells(3, 6).Value = "/"
    Worksheets("ResultList").Cells(3, 7).Value = .Paragraphs.Count
    
    writeRowPos = GetMidashi(fileNameKey, wdDoc, pageCnt, writeRowPos)
    writeRowPos = writeRowPos + 1
  End With

  wdDoc.Close
  Set wdDoc = Nothing
  wdApp.Quit saveChanges:=wdDoNotSaveChanges
  Set wdApp = Nothing
  GetFileInfo = writeRowPos
End Function


Function GetMidashi(fileNameKey As String, wdDoc As Word.Document, pgCnt As Integer, writeRowPos As Integer) As Integer
  Dim par As Paragraph
  Dim beforePar As Integer
  
  Dim paraCnt As Integer
  Dim honbunCnt As Integer

  Dim item1num As String
  Dim item1content As String
  Dim item2num As String
  Dim item2content As String
  
  Dim honbunContent As String
  Dim honbunContentBfr As String

  paraCnt = 1
  honbunCnt = 0
  
  For Each par In wdDoc.Paragraphs
    Worksheets("ResultList").Cells(3, 5).Value = paraCnt
    
    If ((beforePar = 10) And (par.OutlineLevel <> 10)) Then
      honbunContentBfr = ""
      beforePar = par.OutlineLevel
      honbunCnt = 0
      writeRowPos = writeRowPos + 1
    End If
      
    If par.OutlineLevel = 2 Then
      honbunCnt = 0
      If "" <> Replace(par.Range.Text, vbCr, "") Then
        item1num = par.Range.ListFormat.ListString
        item1content = Trim(par.Range.Text)
        item1content = Replace(item1content, vbCr, "")
        beforePar = par.OutlineLevel
      End If
    End If
      
    If par.OutlineLevel = 3 Then
      honbunCnt = 0
      If "" <> Replace(par.Range.Text, vbCr, "") Then
        
        Worksheets("ResultList").Cells(writeRowPos, 2).Value = item1num
        Worksheets("ResultList").Cells(writeRowPos, 3).Value = item1content
        Worksheets("ResultList").Cells(writeRowPos, 5).Value = pgCnt
        item2num = par.Range.ListFormat.ListString
        Worksheets("ResultList").Cells(writeRowPos, 9).Value = item2num

        item2content = Trim(par.Range.Text)
        item2content = Replace(item2content, vbCr, "")
        Worksheets("ResultList").Cells(writeRowPos, 10).Value = item2content
        beforePar = par.OutlineLevel
      
        varResultR0100 = Filter(varArrayR0100, item2num)
        varResultR0150 = Filter(varArrayR0150, item2num)
        varResultR0200 = Filter(varArrayR0200, item2num)
      
        If fileNameKey = "04" Then
          Worksheets("ResultList").Cells(writeRowPos, 4).Value = "Screen"
        ElseIf fileNameKey = "05" Then
          Worksheets("ResultList").Cells(writeRowPos, 4).Value = "API"
        ElseIf fileNameKey = "06" Then
          Worksheets("ResultList").Cells(writeRowPos, 4).Value = "Logic"
        End If
      
        If UBound(varResultR0100) <> -1 Then
          Worksheets("ResultList").Cells(writeRowPos, 6).Value = "〇"
        ElseIf UBound(varResultR0150) <> -1 Then
          Worksheets("ResultList").Cells(writeRowPos, 7).Value = "〇"
        ElseIf UBound(varResultR0200) <> -1 Then
          Worksheets("ResultList").Cells(writeRowPos, 8).Value = "〇"
        End If
      End If
    End If
      
    If par.OutlineLevel = 10 Then
      If honbunCnt > 0 Then
        If "" <> Trim(par.Range.Text) Then
          honbunContent = Trim(par.Range.Text)
          honbunContent = Replace(honbunContent, vbCr, "")
          honbunContent = Replace(honbunContent, item2num, "")
          If honbunContentBfr <> honbunContent Then
            honbunContent = honbunContentBfr & honbunContent
            Worksheets("ResultList").Cells(writeRowPos, 11).Value = honbunContent
            honbunContentBfr = honbunContent
          End If
        
          beforePar = par.OutlineLevel
          honbunCnt = honbunCnt + 1
        End If
      End If
      
      If beforePar = 3 Then
        If "" <> Trim(par.Range.Text) Then
          honbunContent = Trim(par.Range.Text)
          honbunContent = Replace(honbunContent, vbCr, "")
          honbunContent = Replace(honbunContent, item2num, "")
          Worksheets("ResultList").Cells(writeRowPos, 11).Value = honbunContent
          honbunContentBfr = honbunContent
          beforePar = par.OutlineLevel
          honbunCnt = 1
        End If
      End If
      
    End If
      
    
    beforePar = par.OutlineLevel
  Next par
  GetMidashi = writeRowPos
End Function

見出し一覧作成Excel