Well I got some time and re-wrote the code. It works as far as the code produces the end product, but I still have the flashing. Its less time, about 7 seconds and then about another 15 seconds on the clock (spinning circle) before I can view anything.
So I must still be doing something wrong. I expect its the outdoc.Activate and the orginialdoc.Activate statements, but I don't understand how to tell the code which document to look in or output the information into without them.
I made two changes in trying to help
Set QuestionAnaswerRange = orginialdoc.Content rather than the
ActiveDocument.Content
and up a few lines I commented out the line ' orginialdoc.Activate
The change on the screen was, I see a gray screen (the new document) and the cursor jumps around with the clock icon. Same amount of time as before the changes.
Here is the code
' global the arrays
Code:
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