asked on
Word is running slower on Windows 10 computer than my old Windows 7 computer.

I recently upgraded from a Windows 7 computer to a Windows 10 computer. I have a Word 2003 file with several complicated macros. They do not run on later versions of Word so I installed Word 2003 on the Windows 10 computer. However the macros run about 3 times slower on the Windows 10 computer than on the old Windows 7 computer. I deleted the normal.dot file, switched to Windows 7 compatibility mode for word and checked that I have no add-ins in Word. None of this helped.

Any ideas?
Thanks
John
Office 2003 is not very compatible with Windows 10 and certainly not supported.

Can you upgrade the macros to a newer version of Office? That will have to happen at some point as Windows 10 moves on and eventually Office 2003 will not even run on versions of Windows 10 yet to come.
John
You can also try making a Windows 7 virtual machine. I have that running in VMware Workstation V15 and it runs fine. Run Office 2003 in the Windows 7 machine.
Qlemo
Can you give us a hint about what tasks the macros do? It is difficult to give advice without details. In general, you should not have performance issues, but if you are using certain kind of external libs and objects, it might be more "difficult" for VBA to run.
thenelson
ASKER
Here is the code:
Sub CopyReport()
Dim FolderName As String, fs
Dim strDocName As String, strNotUpdated As String
Dim oRng As Word.Range, StartPos As Long, EndPos As Long
Dim I As Integer, fld
Dim intTableIndex As Integer, intPrevTableIndex As Integer
Dim strPrevVitalSigns As String, strPrevBMI As String, strPrevPainLvl As String, strPrevMME As String, strPrevDOS As String

On Error Resume Next

If Time > #5:00:00 PM# Then
    UpdateBookmark "DOS", Format(Date + 1, "mmmm d, yyyy")
Else
    UpdateBookmark "DOS", Format(Date, "mmmm d, yyyy")
End If

Set fs = CreateObject("Scripting.FileSystemObject")
FolderName = GetMainFolder & "*Report*.doc"
'If Len(ActiveDocument.Bookmarks("PatientsName").Range.Text & "") > 1 Then FolderName = FolderName & ActiveDocument.Bookmarks("PatientsName").Range.Text & "\"

strDocName = GetWordDoc(FolderName, "Select a file to copy")
If Len(strDocName & "") = 0 Then
    If MsgBox("Remove the ""Get previous data"" field?", vbYesNo) = vbYes Then ActiveDocument.Bookmarks("CopyReport").Range.Font.Hidden = True
    Exit Sub
End If
SetAttr strDocName, vbNormal
Documents.Open strDocName, Visible:=True
'If Documents(strDocName).Range.Bookmarks("recommendation").Range.Paragraphs.Count < 3 Then

Application.ScreenUpdating = False
UpdateDocs

'check if vital signs table exists:
ActiveDocument.Bookmarks("VitalSigns").Select
intPrevTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count

'if no table, get previos vital signs:
If intPrevTableIndex = 0 Then
    strPrevVitalSigns = ActiveDocument.Bookmarks("VitalSigns").Range.Text
    strPrevBMI = Trim(StringBetweenStrings(Selection.Fields(2).Code.Text, "GetBMI "))
    Selection.HomeKey Unit:=wdStory
    Selection.Find.Execute "Current pain level: "
    Selection.EndKey wdLine, True
    strPrevPainLvl = Trim(StringBetweenStrings(Selection.Range.Text, "Current pain level: ", ","))
    Selection.EndKey wdLine
    If Selection.Find.Execute("Daily MME ") Then
        Selection.MoveRight wdCell, 4
        strPrevMME = OnlyNumbers(Selection.Range.Text, ".", True)
    Else
        strPrevMME = ""
    End If
    strPrevDOS = ActiveDocument.Bookmarks("DOS").Range.Text
End If

Documents(strDocName).Close wdSaveChanges
If InStr(strDocName, "Signed") Then SetAttr strDocName, vbReadOnly

ActiveDocument.Bookmarks("CopyReport").Range.Font.Hidden = True
ActiveDocument.Bookmarks("PatientsName").Range.InsertFile strDocName, "PatientsName"
With Selection
   .GoTo What:=wdGoToBookmark, Name:="PatientsName"
   .EndKey wdLine, True
   .MoveLeft wdCharacter, 1, True
End With
ActiveDocument.Bookmarks.Add "PatientsName"
PtName2    'create header, recommendation header and file name
ActiveDocument.Bookmarks("SexHand").Range.InsertFile strDocName, "SexHand"
If Err = 5101 Or Err = 5941 Then strNotUpdated = "Sex and left/right handed" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
ActiveDocument.Bookmarks("DOB").Range.InsertFile strDocName, "DOB"
ComputeAge2
ActiveDocument.Bookmarks("ReferDr").Range.InsertFile strDocName, "ReferDr"
If Err Then
    If Err = 5101 Or Err = 5941 Then
        With Selection
            .GoTo wdGoToBookmark, , , "ReferDr"
            .EndKey wdLine, False
            .HomeKey wdLine, True
            .Font.Hidden = True
        End With
        Err.Clear
    ElseIf Err Then GoTo CopyReportError
    End If
Else
    ReferDr2
End If
ActiveDocument.Bookmarks("Complaint").Range.InsertFile strDocName, "Complaint"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "Complaint" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
ActiveDocument.Bookmarks("Carrier").Range.InsertFile strDocName, "Carrier"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "Carrier" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
ActiveDocument.Bookmarks("ROS").Range.InsertFile strDocName, "ROS"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "ROS" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
'Selection.GoTo What:=wdGoToBookmark, Name:="ROS"
'Selection.MoveRight wdCharacter, 1
'Selection.InsertAfter Chr(13)

ActiveDocument.Bookmarks("allergies").Range.InsertFile strDocName, "allergies"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "allergies" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
ActiveDocument.Bookmarks("exam").Range.InsertFile strDocName, "exam"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "exam section" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError

Selection.GoTo What:=wdGoToBookmark, Name:="CurrentMeds"
Selection.Tables(1).Delete
'Selection.WholeStory
'Selection.Find.Execute "Current medications and supplements:"
'Selection.EndKey Unit:=wdLine
'Selection.TypeParagraph
Selection.InsertFile strDocName, "CurrentMeds"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "Current Medications" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
Selection.WholeStory
Selection.Find.Execute "Current medications and supplements:"
StartPos = Selection.Start
ActiveDocument.Range(StartPos, ActiveDocument.Range.End).Tables(1).Select

ActiveWindow.ActivePane.View.ShowAll = True
'Selection.GoTo What:=wdGoToBookmark, Name:="discontinue"
'Selection.GoTo What:=wdGoToBookmark, Name:="CurrentMeds"
Selection.WholeStory
Selection.Find.Execute "Pain medications discontinued:", , , , , , , , , "Medications discontinued:", True
Selection.WholeStory
Selection.Find.Execute "Medications discontinued:"
If Selection.Find.Found = False Then Selection.Find.Execute "Pain medications discontinued:"
Selection.MoveDown wdLine, 1
Selection.Tables(1).Delete
Selection.InsertFile strDocName, "discontinue"
If Err = 5101 Or Err = 5941 Then Err.Clear Else If Err Then GoTo CopyReportError
'If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "discontinue" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
Selection.WholeStory
Selection.Find.Execute "Medications discontinued:"
If Selection.Find.Found = False Then Selection.Find.Execute "Pain medications discontinued:"
ActiveDocument.Bookmarks.Add "discontinued"
Selection.MoveDown wdLine, 1
Selection.Tables(1).Select
Selection.Font.Hidden = False
ActiveDocument.Bookmarks.Add "discontinue"
ActiveWindow.ActivePane.View.ShowAll = False

'Selection.WholeStory
'Selection.Find.Execute "Allergies and sensitivities:"
'Selection.MoveUp Unit:=wdLine, Count:=1
'Selection.HomeKey Unit:=wdLine
'Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Selection.Font.Hidden = True

With Selection
    .WholeStory
    .Find.MatchCase = True
    .Find.Execute "Allergies and sensitivities:"
    .HomeKey Unit:=wdLine
StartPos = Selection.Start
    .WholeStory
    .Find.Execute "Physical Exam:"
    .HomeKey Unit:=wdLine
'    .MoveLeft wdCharacter, 1
    EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "allergies"
End With

'ActiveDocument.Bookmarks("hgt").Range.InsertFile strDocName, "hgt"
'If Err = 5101 Or Err = 5941 Then
'    strNotUpdated = strNotUpdated & "Height" & vbCrLf: Err.Clear
'ElseIf Err Then GoTo CopyReportError
'Else
'    UpdateBookmark "hgt", " " & Trim(ActiveDocument.Bookmarks("hgt").Range.Text) & " "
'End If

ActiveWindow.ActivePane.View.ShowAll = True
ActiveDocument.Bookmarks("AssessmentOther").Range.Font.Hidden = False
Selection.GoTo What:=wdGoToBookmark, Name:="AssessmentOther"
StartPos = Selection.Start
Selection.InsertFile strDocName, "assessment"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "Assessment" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
ActiveDocument.Bookmarks.Add "AssessmentFromDatabase"
Selection.MoveUp wdLine, 1
Selection.EndKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
ActiveDocument.Range(StartPos, Selection.End).Select
ActiveDocument.Bookmarks.Add "AssessmentOther"
ActiveWindow.ActivePane.View.ShowAll = False

Selection.GoTo What:=wdGoToBookmark, Name:="Recommendation"
Selection.HomeKey Unit:=wdLine
StartPos = Selection.Start
Selection.GoTo What:=wdGoToBookmark, Name:="Complete"
Selection.MoveUp wdLine, 1
Selection.EndKey wdLine
EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "TotalRecommendation"

Selection.GoTo What:=wdGoToBookmark, Name:="Vitalsigns"
intTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count

'if strDocName has the VitalSignsTable:
If intPrevTableIndex = 0 Then     'strDocName does not have the VitalSignsTable
    'copy the previous VitalSigns into the VitalSignsTable:
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(1).Range.Text = Format(strPrevDOS, "mm/dd/yyyy")
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(2).Range.Text = Trim(StringBetweenStrings(strPrevVitalSigns, "BP", ";"))
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(3).Range.Text = Trim(StringBetweenStrings(strPrevVitalSigns, "HR", ";"))
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(4).Range.Text = Trim(StringBetweenStrings(strPrevVitalSigns, "O2 sat", "%"))
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(5).Range.Text = Trim(StringBetweenStrings(strPrevVitalSigns, "", "kg"))
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(6).Range.Text = Trim(StringBetweenStrings(strPrevVitalSigns, "hgt", "cm"))
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(7).Range.Text = Trim(strPrevBMI)
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(8).Range.Text = Trim(strPrevPainLvl)
    ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(9).Range.Text = Trim(strPrevMME)
    HighlightVitalSigns intTableIndex
    
    'add rows if less than 8
    While ActiveDocument.Tables(intTableIndex).Rows.Count < 7
        ActiveDocument.Tables(intTableIndex).Rows.Add ActiveDocument.Tables(intTableIndex).Rows(2)
    Wend
Else                        'strDocName does have the VitalSignsTable
    ActiveDocument.Bookmarks("VitalSigns").Range.InsertFile strDocName, "VitalSigns"
    'delete rows if more than 8
    While ActiveDocument.Tables(intTableIndex).Rows.Count > 7
        ActiveDocument.Tables(intTableIndex).Rows(3).Delete
    Wend
End If

'add a row:
ActiveDocument.Tables(intTableIndex).Rows.Add
'put DOS in column 1 of last row:
ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(1).Range.Text = Format(ActiveDocument.Bookmarks("DOS").Range.Text, "mm/dd/yyyy")
'copy height from second to last row to last row:
ActiveDocument.Tables(intTableIndex).Rows.Last.Cells(6).Range.Text = OnlyNumbers(ActiveDocument.Tables(intTableIndex).Rows(ActiveDocument.Tables(intTableIndex).Rows.Count - 1).Cells(6).Range.Text, ".")

'Selection.Delete Unit:=wdCharacter, Count:=1
'Selection.MoveLeft wdCharacter
'EndPos = Selection.End
'
'Selection.HomeKey wdStory
'Selection.Find.Execute "Vital signs:"
'Selection.Find.Execute "Vital signs:"
'Selection.MoveUp wdLine, 1
'Selection.HomeKey Unit:=wdLine
'Selection.MoveRight wdWord, 2, wdExtend
'Selection.TypeText Text:=GetDocDate(strDocName) & ":"
'Selection.HomeKey Unit:=wdLine
'ActiveDocument.Range(Selection.Start, EndPos).Select
'
'With Selection.Find
'    .Text = ": "
'    .Replacement.Text = ":^t"
'    .Forward = True
'    .Wrap = wdFindStop
'    .Format = False
'    .MatchCase = False
'    .MatchWholeWord = False
'    .MatchWildcards = False
'    .MatchSoundsLike = False
'    .MatchAllWordForms = False
'    .Execute Replace:=wdReplaceAll
'
'    .Text = "; "
'    .Replacement.Text = ";^t"
'    .Execute Replace:=wdReplaceAll
'
'    .Text = "%;^t"
'    .Replacement.Text = "%, "
'    .Execute Replace:=wdReplaceAll
'
'    .Text = "^t^t"
'    .Replacement.Text = "^t"
'    .Execute Replace:=wdReplaceAll
'
'    .Text = "^l"
'    .Replacement.Text = "^p"
'    .Execute Replace:=wdReplaceAll
'
'    .Text = "  "
'    .Replacement.Text = " "
'    .Execute Replace:=wdReplaceAll
'End With
'
'Selection.ParagraphFormat.TabStops.ClearAll
'Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(1.25), _
'    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
'Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(2), _
'    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
'Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(2.63), _
'    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
'Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(4.25), _
'    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
'Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(5.38), _
'    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
'Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(6.25), _
'    Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces

'Selection.MoveUp wdLine, 1
'Selection.HomeKey wdLine
'Selection.EndKey wdLine, wdExtend
'ActiveDocument.Bookmarks.Add "VitalSigns"
'
'Selection.GoTo What:=wdGoToBookmark, Name:="VitalSigns"
'Selection.MoveDown wdLine, 1, wdExtend
'ActiveDocument.Bookmarks.Add "FullVitalSigns"

Selection.GoTo What:=wdGoToBookmark, Name:="HistoryEnd"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "HistoryEnd" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
'Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.InsertFile strDocName, "recommendation"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "Recommendations/Plans" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError

'Selection.MoveUp Unit:=wdLine, Count:=1
'Selection.EndKey Unit:=wdLine
Selection.Delete Unit:=wdCharacter, Count:=1

Selection.GoTo wdGoToBookmark, , , "progress"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "progress" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
'DeleteHidden

ActiveDocument.Bookmarks("SocialHistory").Range.InsertFile strDocName, "SocialHistory"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "SocialHistory" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError

Selection.GoTo What:=wdGoToBookmark, Name:="HistoryLastLine"
With Selection.ParagraphFormat
    .LeftIndent = InchesToPoints(0.5)
    .RightIndent = InchesToPoints(0)
    .SpaceBefore = 0
    .SpaceBeforeAuto = False
    .SpaceAfter = 0
    .SpaceAfterAuto = False
    .LineSpacingRule = wdLineSpaceSingle
    .Alignment = wdAlignParagraphLeft
    .WidowControl = True
    .KeepWithNext = True
    .KeepTogether = True
    .PageBreakBefore = False
    .NoLineNumber = False
    .Hyphenation = True
    .FirstLineIndent = InchesToPoints(-0.25)
    .OutlineLevel = wdOutlineLevelBodyText
    .CharacterUnitLeftIndent = 0
    .CharacterUnitRightIndent = 0
    .CharacterUnitFirstLineIndent = 0
    .LineUnitBefore = 0
    .LineUnitAfter = 0
End With


ActiveDocument.Bookmarks("CCbookmark").Range.InsertFile strDocName, "CCListAll"
If Err = 5101 Or Err = 5941 Then strNotUpdated = strNotUpdated & "Copy list" & vbCrLf: Err.Clear Else If Err Then GoTo CopyReportError
Application.DisplayAlerts = False
Selection.GoTo wdGoToBookmark, , , "CCbookmark"
Application.DisplayAlerts = True
If Err = 5101 Then
    With Selection
        .HomeKey wdStory
        .Find.Execute "cc:"
        If .Find.Found = False Then
            For Each fld In ActiveDocument.Fields
                If InStr(fld.Code.Text, "FaxCopyList cc") Then
                    fld.Select
                    Exit For
                End If
            Next fld
        End If
        .MoveRight wdWord, 2
        ActiveDocument.Bookmarks.Add "CCbookmark"
        Err.Clear
        .GoTo wdGoToBookmark, , , "CCbookmark"
    End With
End If
Selection.MoveDown wdScreen, 1, wdExtend
Selection.MoveLeft wdCharacter, 1, wdExtend
'DeleteHidden
With Selection.Find
    .ClearFormatting
    .Text = "^l^l"
    .Font.Hidden = False
    .Replacement.Text = "^l"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    .Execute Replace:=wdReplaceAll
End With

ActiveWindow.ActivePane.View.ShowAll = True
For I = 0 To 9
    ActiveDocument.Bookmarks("ForNextVisit" & I).Range.Font.Hidden = False
Next I
ActiveWindow.ActivePane.View.ShowAll = False

With Selection
    .WholeStory
    .Font.Size = 10
    With .Find
        .ClearFormatting
        .Text = "Also present: "
        .Font.Hidden = False
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = False
        .Execute
    End With
    .HomeKey Unit:=wdLine
    .EndKey Unit:=wdStory, Extend:=wdExtend
    .Font.Size = 9
    .HomeKey Unit:=wdStory
    .EndKey Unit:=wdLine, Extend:=wdExtend
    .Font.Size = 14
    .HomeKey wdStory
    .Find.Execute "are found in the following areas:"
    ActiveWindow.ActivePane.View.ShowAll = True
    .MoveDown wdLine, 3
    .HomeKey wdLine
    .EndKey wdLine, wdExtend
    .Font.Size = 1
    ActiveWindow.ActivePane.View.ShowAll = False
    .HomeKey Unit:=wdStory
End With

If intPrevTableIndex = 0 Then newVitalSignsTable intTableIndex

ActiveWindow.View.DisplayPageBoundaries = False

On Error Resume Next
If Not GetAttr(ActiveDocument.FullName) And vbReadOnly Then ActiveDocument.Save
Application.ScreenUpdating = True

If Len(strNotUpdated & "") Then
    If MsgBox("Items not copied:" & vbCrLf & strNotUpdated & vbCrLf & "Open the previous file?", vbYesNo) = vbYes Then
        Documents.Open strDocName
    End If
End If

Exit Sub
CopyReportError:
MsgBox "Unhandled error in CopyReport sub" & vbCrLf & Err.Number & ": " & Err.Description & " Line #: " & Erl

End Sub


Sub UpdateDocs()
Dim StartPos, EndPos, fld
Dim booReadOnly As Boolean

booReadOnly = ActiveDocument.ReadOnly

With Selection
    .WholeStory
    With .Find
        .ClearFormatting
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute "Patient:"
    End With
    .MoveDown Unit:=wdLine, Count:=1
    .MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
    .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
ActiveDocument.Bookmarks.Add "SexHand"

ActiveWindow.ActivePane.View.ShowAll = True
    .WholeStory
    .Find.Execute "Medications discontinued:"
    If .Find.Found = False Then .Find.Execute "Pain medications discontinued:"
    If .Find.Found = False Then
        .Find.Execute "Allergies and sensitivities:"
        .MoveUp wdLine, 1
        .Tables(1).Select
        .MoveUp wdLine, 1
        .TypeText "Medications discontinued:"
        .HomeKey wdLine
        .EndKey wdLine, True
    End If
    .Font.Hidden = False
    ActiveDocument.Bookmarks.Add "discontinued"
    .MoveDown wdLine, 1
    .Tables(1).Select
    .Font.Hidden = False
ActiveDocument.Bookmarks.Add "discontinue"
ActiveWindow.ActivePane.View.ShowAll = False
    
    
    .WholeStory
    .Find.Execute "Complaint:"
    .MoveRight Unit:=wdCharacter, Count:=2
    .EndKey Unit:=wdLine, Extend:=wdExtend
ActiveDocument.Bookmarks.Add "Complaint"

    .WholeStory
    .Find.Execute "Carrier:"
    .MoveRight Unit:=wdCharacter, Count:=2
    .EndKey Unit:=wdLine, Extend:=wdExtend
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="Carrier"
    
    .WholeStory
    .Find.Execute "ROS: "
    .HomeKey wdLine
ActiveDocument.Bookmarks.Add "HistoryEnd"
    
    .MoveUp wdLine, 1
    .HomeKey Unit:=wdLine
ActiveDocument.Bookmarks.Add "HistoryLastLine"
    '.EndKey Unit:=wdLine

    .WholeStory
    .Find.MatchCase = True
    .Find.Execute "ROS"
    .MoveDown Unit:=wdLine, Count:=1
    .HomeKey Unit:=wdLine
StartPos = Selection.Start
    .WholeStory
    .Find.Execute "Activity tolerance:"
    .EndKey Unit:=wdLine
    EndPos = Selection.End + 1
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "ROS"

    .WholeStory
    .Find.MatchCase = True
    .Find.Execute "Allergies and sensitivities:"
    .HomeKey Unit:=wdLine
StartPos = Selection.Start
    .WholeStory
    .Find.Execute "Physical Exam:"
    .HomeKey Unit:=wdLine
'    .MoveLeft wdCharacter, 1
    EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "allergies"

    .WholeStory
    .Find.Execute "Social history:"
    .MoveRight Unit:=wdWord, Count:=1
    StartPos = Selection.Start
    .Find.Execute "^p"
    .MoveLeft Unit:=wdCharacter, Count:=1
    EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "SocialHistory"

    .GoTo What:=wdGoToBookmark, Name:="VitalSigns"
    .EndKey wdLine
    .Find.Execute "General:"
    .HomeKey wdLine
    StartPos = Selection.Start
    .Find.Execute "Musculoskeletal:"
    .HomeKey wdLine
    EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "exam"
    .WholeStory
    .Find.Execute "Current medications and supplements"
    .EndKey wdLine
StartPos = Selection.Start
ActiveDocument.Range(StartPos, ActiveDocument.Range.End).Tables(1).Select
ActiveDocument.Bookmarks.Add "CurrentMeds"

For Each fld In ActiveDocument.Fields
    If InStr(fld.Code.Text, "Assessment") Then
        fld.Select
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.HomeKey Unit:=wdLine
        StartPos = Selection.Start
        Exit For
    End If
Next fld

    .WholeStory
    .Find.Execute "/Plan:"
If .Find.Found = False Then
    For Each fld In ActiveDocument.Fields
        If InStr(fld.Code.Text, "VisitSummary") Then
            fld.Select
            Exit For
        End If
    Next fld
End If
'    .MoveUp Unit:=wdLine, Count:=1
    .HomeKey Unit:=wdLine
EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "assessment"

    .WholeStory
    .Find.Execute "/Plan:"
If .Find.Found = False Then
    For Each fld In ActiveDocument.Fields
        If InStr(fld.Code.Text, "VisitSummary") Then
            fld.Select
            Exit For
        End If
    Next fld
End If
.EndKey Unit:=wdLine
StartPos = Selection.Start

ActiveWindow.ActivePane.View.ShowAll = True
    .WholeStory
    .Find.Execute "Counseling and education:"
If .Find.Found = False Then
    .WholeStory
    .Find.Execute "Follow up with me"
End If
.HomeKey Unit:=wdLine
EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "recommendation"
ActiveWindow.ActivePane.View.ShowAll = False

    .GoTo What:=wdGoToBookmark, Name:="Recommendation"
    .HomeKey Unit:=wdLine
    StartPos = Selection.Start
    .GoTo What:=wdGoToBookmark, Name:="Complete"
    .MoveUp wdLine, 1
    .EndKey wdLine
    EndPos = Selection.End
    ActiveDocument.Range(StartPos, EndPos).Select
    ActiveDocument.Bookmarks.Add "TotalRecommendation"

'    .GoTo What:=wdGoToBookmark, Name:="Recommendation"
'    StartPos = Selection.Start
'    .GoTo What:=wdGoToBookmark, Name:="RecommendCounseling"
'    .MoveLeft wdCharacter, 2
'    EndPos = Selection.End
'    ActiveDocument.Range(StartPos, EndPos).Select
'    ActiveDocument.Bookmarks.Add "Recommendation"

    .HomeKey wdStory
    .Find.Execute "cc:"
    If .Find.Found = False Then
        For Each fld In ActiveDocument.Fields
            If InStr(fld.Code.Text, "FaxCopyList cc") Then
                fld.Select
                Exit For
            End If
        Next fld
    End If
    .MoveRight wdWord, 2
    ActiveDocument.Bookmarks.Add "CCbookmark"
    StartPos = Selection.Start
    .EndKey Unit:=wdStory
EndPos = Selection.End
ActiveDocument.Range(StartPos, EndPos).Select
ActiveDocument.Bookmarks.Add "CCListAll"

'    .WholeStory
'    .Find.Execute "Vital signs:"
'    .HomeKey Unit:=wdLine
'    .EndKey Unit:=wdLine, Extend:=wdExtend
'ActiveDocument.Bookmarks.Add "VitalSigns"
End With

Set fld = Nothing
End Sub
Open in new window
ASKER CERTIFIED SOLUTION
thenelson
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial