VBA实现Word按章节提取项目符号内容并导出至Excel

• 从Word文档中，针对以Level 1标题“3.”开头的各级章节（Level1-4），统计其中带项目符号样式的发现内容的出现次数
• 记录发现内容所在的标题层级，将对应层级标题（H1-H4）、次数、发现内容等信息导出至预定义Excel模板
• 现有exportToExcel代码已实现部分列填充，需补充章节标题（H1-H4）列及相关统计逻辑

现有代码 #

'code I use for the remaining columns
Public Sub exportToExcel()

Const strTemplateName As String = "check-doc.xlsm"
Dim doc As Document, cc As ContentControl
Dim strFolder As String
Dim counterForMeasures As Integer
Dim counterForFindings As Integer
Dim counterForHeading1 As Integer
Dim g As Integer, a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer, h As Integer, i As Integer, priorityPlaceholder
Dim strAutidNr As String
Dim arrSplitStrAuditNr() As String
Dim strdate1 As String
Dim strdate2 As String
Dim arrSplitDate() As String
Dim MonthsDE As String
Dim MonthsEN As String
Dim arrMonthsDE() As String
Dim arrMonthsEN() As String
MonthsDE = "Januar Februar März April Mai Juni Juli August September Oktober November Dezember"
MonthsEN = "January February March April May June July August September October November December"
arrMonthsDE = Split(MonthsDE, " ")
arrMonthsEN = Split(MonthsEN, " ")
Dim cr2 As String
Dim xlwb As Excel.Workbook, xlApp As Excel.Application
Dim xlwsh As Excel.Worksheet


Set doc = ThisDocument
strFolder = ActiveDocument.AttachedTemplate.Path & Application.PathSeparator & strTemplateName

If Not MyFileExists(strFolder) Then
MsgBox strFolder, vbInformation, "Template does not exist"
Exit Sub
End If
Call UnlockAllCC ' sperre lösen

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlwb = xlApp.Workbooks.Add(Template:=strFolder)
Set xlwsh = xlwb.Worksheets("Tabelle1")

'M count
counterForMeasures = 2 ' header berücksichtigen
For Each cc In ActiveDocument.ContentControls
If cc.Tag = "cc_TextMaßnahme" Then
counterForMeasures = counterForMeasures + 1
End If
Next cc

' bulleted style count
counterForFindings = 2 ' header berücksichtigen
For Each cc In ActiveDocument.ContentControls
If cc.Tag = "cc_eineFeststellung" Then
counterForFindings = counterForFindings + 1
End If
Next cc

' Heading1 count// cc_Heading1
counterForHeading1 = 2 ' header berücksichtigen
For Each cc In ActiveDocument.ContentControls
If cc.Tag = "cc_Heading1" Then
counterForHeading1 = counterForHeading1 + 1
End If
Next cc



'a = 3 ' Datum
For a = 3 To counterForFindings
For Each cc In ActiveDocument.ContentControls

If cc.Tag = "cc_DatumRevisionsbericht" Then

If cc.Range.Text <> "Klicken oder tippen Sie, um ein Datum einzugeben." And cc.Range.Text <> "Click or tap to enter a date." Then
cc.LockContents = False

If cc.Range.Text Like "*.*" Then
arrSplitDate = Split(cc.Range.Text, ".")
'strdate1 = arrSplitDate(0)
strdate2 = arrSplitDate(1)
arrSplitDate = Split(strdate2, " ")
strdate1 = arrSplitDate(2)
strdate2 = arrSplitDate(1)
If strdate2 = arrMonthsEN(0) Or strdate2 = arrMonthsDE(0) Then
strdate2 = "01"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(1) Or strdate2 = arrMonthsDE(1) Then
strdate2 = "02"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(2) Or strdate2 = arrMonthsDE(2) Then
strdate2 = "03"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(3) Or strdate2 = arrMonthsDE(3) Then
strdate2 = "04"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(4) Or strdate2 = arrMonthsDE(4) Then
strdate2 = "05"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(5) Or strdate2 = arrMonthsDE(5) Then
strdate2 = "06"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(6) Or strdate2 = arrMonthsDE(6) Then
strdate2 = "07"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(7) Or strdate2 = arrMonthsDE(7) Then
strdate2 = "08"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(8) Or strdate2 = arrMonthsDE(8) Then
strdate2 = "09"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(9) Or strdate2 = arrMonthsDE(9) Then
strdate2 = "10"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(10) Or strdate2 = arrMonthsDE(10) Then
strdate2 = "11"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
If strdate2 = arrMonthsEN(11) Or strdate2 = arrMonthsDE(11) Then
strdate2 = "12"
xlwsh.Range("A" & a).Value = strdate1 & " " & strdate2
End If
End If
End If
End If

Next cc
Next a


'b = 3 ' Gep einheit -
strAutidNr = GetNr(ActiveDocument)
If strAutidNr Like "*_*" Then
arrSplitStrAuditNr = Split(strAutidNr, "_")

For b = 3 To counterForFindings
xlwsh.Range("B" & b).Value = arrSplitStrAuditNr(1)

Next b
End If





'c = 3 ' h1



'd = 3 ' h2


'e = 3 ' h3


'f = 3 ' h4


g = 3 ' bulleted style
For Each cc In ActiveDocument.ContentControls

If cc.Tag = "cc_eineFeststellung" Then
cc.LockContents = False
xlwsh.Range("G" & g).Value = cc.Range.Text
If g = counterForFindings Then
Exit For
End If
g = g + 1
End If
Next cc


h = 3 ' M
For Each cc In ActiveDocument.ContentControls

If cc.Tag = "cc_TextMaßnahme" Then
cc.LockContents = False
xlwsh.Range("H" & h).Value = cc.Range.Text
If h = counterForMeasures Then
Exit For
End If
h = h + 1
End If

Next cc

i = 3 ' priorität
For Each cc In ActiveDocument.ContentControls

If cc.Tag = "cc_Nr" Then
cc.LockContents = False
priorityPlaceholder = Left(cc.Range.Text, 1)

xlwsh.Range("I" & i).Value = priorityPlaceholder
If i = counterForMeasures Then
Exit For
End If
i = i + 1
End If

Next cc

' close obj instancen
Set xlwb = Nothing
Set xlApp = Nothing
Set xlwsh = Nothing
Set doc = Nothing

Call LockAllCC ' sperre setzen
End Sub

内容的提问来源于stack exchange，提问作者KnechtenP99