Option Explicit

Public list_of_lists_of_ingredients_ranges  As Collection
Public ingredients_directory                As String

Sub covert_lists_of_ingredients_to_includetext_fields()

Dim index                               As Integer
Dim list_of_ingredients                 As Word.Range
Dim ingredients_path                    As String
Dim ingredients_range                   As Word.Range

    'create a directory for the ingredient files
    ingredients_directory = ActiveDocument.Path & "\" & Replace(ActiveDocument.Name, ".docx", vbNullString) & "_ingredients"
    If Len(Dir(ingredients_directory, vbDirectory)) = 0 Then
        MkDir ingredients_directory
    End If
    compile_list_of_lists_of_ingredients_ranges
    
    'create a document for each set of ingredients and insert insterttextfield
    For index = 1 To list_of_lists_of_ingredients_ranges.Count
    
        ingredients_path = create_ingredients_document(index)
        
        Set ingredients_range = list_of_lists_of_ingredients_ranges(index)
        With ingredients_range
            .Delete
            .Fields.Add _
                Range:=ingredients_range, _
                Type:=wdFieldIncludeText, _
                Text:=Chr$(34) & Replace(ingredients_path, "\", "\\") & Chr$(34), _
                preserveformatting:=False
        End With
    Next
    
End Sub

Sub compile_list_of_lists_of_ingredients_ranges()

Dim search_range                        As Word.Range
Dim ingredient_heading_ranges           As Collection
Dim heading_range                       As Variant
    
    Set ingredient_heading_ranges = New Collection
    Set search_range = ActiveDocument.StoryRanges(wdMainTextStory)
    
    With search_range.Find
        Do
            .ClearFormatting
            .Format = True
            .Wrap = wdFindStop
            .Style = "Heading 4"
            .Text = "Ingredients"
            .Execute
            If .Found Then
                ingredient_heading_ranges.Add search_range.Duplicate
            End If
        Loop While .Found
    End With
    
    Set list_of_lists_of_ingredients_ranges = New Collection
    
    ' now get the ranges for the lists of ingedients
    For Each heading_range In ingredient_heading_ranges
        list_of_lists_of_ingredients_ranges.Add get_ingredients_range_from_heading_range(heading_range)
    Next
        
End Sub

Function get_ingredients_range_from_heading_range(this_range As Variant) As Word.Range

    this_range.Move unit:=wdParagraph
    Do Until this_range.Next(unit:=wdParagraph).Style = "Normal"
        this_range.MoveEnd unit:=wdParagraph
    Loop
    Set get_ingredients_range_from_heading_range = this_range
    
End Function

Function create_ingredients_document(this_item As Integer) As String ' name of document
Dim this_doc                            As Word.Document
    
    Set this_doc = Application.Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
    this_doc.StoryRanges(wdMainTextStory).FormattedText = list_of_lists_of_ingredients_ranges(this_item).FormattedText
    this_doc.StoryRanges(wdMainTextStory).Characters.Last.Delete
    this_doc.SaveAs2 _
        ingredients_directory _
        & "\" _
        & Replace(ActiveDocument.Name, ".docx", "_ingredients_" & Format(this_item, "00") & ".docx")
      
        
    create_ingredients_document = this_doc.FullName
    this_doc.Close savechanges:=False
End Function

Sub ShowHideIngredients()
Application.ScreenUpdating = False
With ActiveDocument
  With .Styles("Ingredients").Font
    .Hidden = Not .Hidden
  End With
  With .Styles("IngredientItems").Font
    .Hidden = Not .Hidden
  End With
End With
Application.ScreenUpdating = True
End Sub

Sub ShowHideIngredients()
Application.ScreenUpdating = False
Dim RngHd As Range
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Ingredients"
    .Style = wdStyleHeading4
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = True
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    Set RngHd = .Paragraphs(1).Range
    Set RngHd = RngHd.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    RngHd.Font.Hidden = Not RngHd.Font.Hidden
    .Start = RngHd.End
    .Find.Execute
  Loop
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub