Option Explicit
Dim ChapterArray(1 To 900) As Integer
Dim UniqueChapterArray(1 To 900) As Integer

Dim QuestionArray(1 To 900) As String
Dim answer(1 To 900) As String
Dim sta As Integer
Dim enda As Integer
Dim fchapterbreak As Boolean
Sub GenByChapter()

' Generate Technician questions by chapters
'
Dim p As Paragraph
Dim pstring As String
Dim MaxNumber As Integer
Dim UniqueMaxNumber As Integer
Dim TabLocation As Integer
Dim QuestionAnaswerRange As Range
Dim StartWord As String
Dim EndWord As String
Dim ftext As String
Dim fftext As String
Dim OldChapter As Integer
Dim bl As Integer
Dim nl As Integer
Dim iii As Integer
Dim orginialdoc As Document
Dim questiondoc As Document
Dim outdoc As Document
Dim kk As Integer
Dim sect As Section

fchapterbreak = True
' Get information of questions by chapter in arrays
' C:\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters.docx
Set orginialdoc = ActiveDocument
Application.ScreenUpdating = False

Set questiondoc = Documents.Open(FileName:="\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters 2018.docx", ConfirmConversions _
        :=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:="")
MaxNumber = 0
UniqueMaxNumber = 0
For Each p In questiondoc.Paragraphs
    ' convert paragraph to a string of characters
    pstring = p.Range.Text
    ' drop paragraph character
    pstring = Left(pstring, Len(pstring) - 1)
        ' Debug.Print ">" & pstring & ">" & Len(pstring);
    ' find the tab - chr(9) is a tab
    TabLocation = InStr(1, pstring, Chr(9))
    MaxNumber = MaxNumber + 1
    ChapterArray(MaxNumber) = Mid$(pstring, 1, TabLocation - 1)
    QuestionArray(MaxNumber) = Mid$(pstring, TabLocation + 1)
    If UniqueMaxNumber <> 0 Then
        If ChapterArray(MaxNumber) <> UniqueChapterArray(UniqueMaxNumber) Then
            UniqueMaxNumber = UniqueMaxNumber + 1
            UniqueChapterArray(UniqueMaxNumber) = ChapterArray(MaxNumber)
        End If
    End If
    If UniqueMaxNumber = 0 Then
        UniqueMaxNumber = 1
        UniqueChapterArray(UniqueMaxNumber) = ChapterArray(MaxNumber)
    End If
Next p
' close the document with the questions by chapter
questiondoc.Close
Set questiondoc = Nothing
' focus on the question document
orginialdoc.Activate

Application.ScreenUpdating = False

OldChapter = -9
 Set outdoc = Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
outdoc.Activate
Application.ScreenUpdating = False
Call setmargins(outdoc)
Application.ScreenUpdating = False
sta = 1
For kk = 1 To MaxNumber
    orginialdoc.Activate
    StartWord = QuestionArray(kk)
    EndWord = "~~"
    ' build the find for the question
    Set QuestionAnaswerRange = ActiveDocument.Content
    QuestionAnaswerRange.Find.ClearFormatting
    QuestionAnaswerRange.Find.Replacement.ClearFormatting
    With QuestionAnaswerRange.Find
        .Text = StartWord & "*" & EndWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False '
    End With
    ' do the find
    QuestionAnaswerRange.Find.Execute
    ' see if a new chapter
    If OldChapter <> ChapterArray(kk) Then
        OldChapter = ChapterArray(kk)
        Call newchapter(OldChapter, outdoc)
        sta = kk
        End If
    ' change formation back to normal
    outdoc.Activate
    Selection.Style = ActiveDocument.Styles("Normal")
  
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    'Selection.InsertParagraph
    ' get the found text
    ftext = QuestionAnaswerRange.Text
    ' find the first blank and then the ")"
    bl = InStr(ftext, " ")
    answer(kk) = Mid(ftext, bl + 1, 3)
    nl = InStr(ftext, Chr(13)) + 1
    fftext = QuestionArray(kk) & Chr(13) & Mid(ftext, nl)
    enda = kk
 'GoTo exitout
    Selection.TypeText (fftext)
    Selection.TypeParagraph
'       Debug.Print QuestionAnaswerRange.Text
next
'output a page break
outdoc.Activate
Selection.InsertBreak Type:=wdPageBreak
     'spill the answers
For iii = sta To enda
    Selection.TypeText (QuestionArray(iii) & " " & answer(iii))
    Selection.TypeParagraph
Next
kk = 0
For Each sect In outdoc.Sections
    ' unlink
    With sect.Headers(wdHeaderFooterPrimary)
        .LinkToPrevious = False
        kk = kk + 1
        .Range.Text = "Questions for chapter " & UniqueChapterArray(kk)
        .Range.Font.Size = 20
        .Range.Font.Name = "Arial"
        .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
Next sect
orginialdoc.Activate
exitout:
 Application.ScreenUpdating = True
    End Sub
Sub newchapter(i, outdoc)
 Dim ii As Integer
 outdoc.Activate
If Not fchapterbreak Then
    'output a page break
     Selection.StartOf unit:=wdParagraph
            Selection.Collapse Direction:=wdCollapseEnd
            Selection.InsertBreak (wdPageBreak)
     'spill the answers
     For ii = sta To enda
        Selection.TypeText (QuestionArray(ii) & " " & answer(ii))
        Selection.TypeParagraph
        Next
    Selection.StartOf unit:=wdParagraph
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.InsertBreak (wdSectionBreakNextPage)
Else
    fchapterbreak = False
    End If
    End Sub
Sub setmargins(outdoc)
'Dim qdoc As Document
    With outdoc.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.3)
        .BottomMargin = InchesToPoints(0.3)
        .LeftMargin = InchesToPoints(0.4)
        .RightMargin = InchesToPoints(0.3)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .PageWidth = InchesToPoints(8.5)
        .PageHeight = InchesToPoints(11)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
End Sub