VBA Word find text with a special style in heading level/chapter

Question

In the whole doc are data that I need to write in a predefined excel per chapter (headings level 1 - 4) there are findings (text with bulleted style) so if there is a finding in this chapter i have to look how many times so i can write it in excel according to the number, and continue to the next chapter as an example ( hopefully better than the last one ..)
Required chapters start with 3. ( headings level 1 )
3. Ü3
any text
3.1 Ü3.1
any text
3.1.1 Ü3.1.1
any text
3.1.2 Ü3.1.2
any text
3.1.2.1 Ü3.1.2.1
• Text with bulleted style > I searching
• Text with bulleted style > I searching
3.1.2.2 Ü3.1.2.2
any text
4. Ü4
any text
4.1 Ü4.1
• Text with bulleted style > I searching
5. Ü5
5.1 Ü5.1
5.2 Ü5.2
• Text with bulleted style > I searching
6. Ü6
This would mean with the example above that in chapter 3 (3. - 3.1.2.1) 2x text occurs with bulleted style 3.1.2.2 I can ignore because in 3.1.2.1 the text I am looking for already occurs means I have to write in excel
2x
Ü3 in column c3/c4
Ü3.1 in column d3/4
Ü3.1.2 in column e3/4
and most important the headline level where the text occurs Ü3.1.2.2 in column f3/4
thereafter to the next chapter 4.
so in this chapter is this text, yes? how many times does it occur (the number of times i have to write it in excel) and what level does it occur because i have to have that in excel
Should then look like this in excel

'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

Answer 1

It doesn't look like Word can find a character/paragraph style embedded in a paragraph. i.e if I have a paragraph of text in Heading 1 style and I format a word of that heading as Body Text 3 (a combined character/paragraph style) with italic attribute added, I can see that the word is italic but the Bofy Text 3 style can't be found.

However Word can find one or more font attributes for the 'Body Text 3' style, specifically in this case the italic text.

The following code may be of help

Option Explicit


Sub test()

    ' Body Text 3 has also had the italic formatting added to the style.
    CountStyleInHeadings ("Body Text 3")
End Sub
Public Function CountStyleInHeadings(ByVal ipStylename As String) As Variant

    Dim myCounts As Variant
    ReDim myCounts(1 To 9)
    
    Dim myPara As Variant
    For Each myPara In ActiveDocument.StoryRanges(wdMainTextStory).Paragraphs
    
        Dim myRange As Range
        Set myRange = myPara.Range
        myRange.Select
        If myPara.OutlineLevel <> wdOutlineLevelBodyText Then
        
            If StyleNameFound(myRange, ipStylename) Then
            
                myCounts(myPara.OutlineLevel) = myCounts(myPara.OutlineLevel) + 1
                
            End If
            
        End If
            
    Next
    
End Function


Public Function StyleNameFound(ByRef ipParagraph As Range, ByRef ipStylename As String)
    Debug.Print ipParagraph.Text
    Debug.Print ipStylename
    With ipParagraph.Find
    
        .ClearFormatting
        .Font.Italic = True
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
    End With
    
    Debug.Print ipParagraph.Find.Found
    StyleNameFound = ipParagraph.Find.Found
End Function

Answer 2

Here's some code to get you started. It returns the heading level, heading text & bullet text for each paragraph in the 'Bullet' style.

Sub GetBulletHeadings()
Application.ScreenUpdating = False
Dim RngHd As Range
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = "Bullet"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False
  End With
  Do While .Find.Execute
    Set RngHd = .Paragraphs(1).Range.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    MsgBox Right(RngHd.Paragraphs.First.Range.Style, 1) & vbCr & RngHd.Paragraphs.First.Range.Text & vbCr & .Text
    .Collapse wdCollapseEnd
  Loop
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub