Consulting

Results 1 to 17 of 17

Thread: Large Word Doc with many Duplicate Headings

  1. #1

    Large Word Doc with many Duplicate Headings

    Hey folks!

    I have an issue I would love some help with. I have a document that gets spit out from an enterprise tool I use for work, and due to how things are set up, many Heading 2 headings are doubled.

    I'm trying to get a macro together that will find Heading 2 headings and delete them if they have no content, OR if they are immediately followed by another Heading 2 heading that is identical (always the first Heading needs to be removed)

    I tried this code:

    Sub RemoveHeadingsWithNoContent()
    
    
    Dim HeadingF As Range
    Set HeadingF = ActiveDocument.Content
    
    
    With HeadingF.Find
        .Style = "Heading 2"
        .Forward = True
        .Wrap = wdFindStop
    End With
    
    
    Do
        HeadingF.Find.Execute
        If HeadingF.Find.Found Then
    
    
            If HeadingF.Paragraphs(1).Next.Range.Style <> "Normal" Then
    
    
                HeadingF.Delete
    
    
             End If
        End If
    Loop While HeadingF.Find.Found
    
    
    End Sub
    That seems to work on smaller test documents, but the ones I need this macro to run on are from 4000 - 10000 pages long. When I run this on the proper document, it freezes up Word. I have tried leaving it overnight and it never recovers.

    Any suggestions would be greatly appreciated. I am very new to VBA, so this is throwing me for a loop.

  2. #2
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    262
    Location
    Can you attach a small sample?

  3. #3
    Academic Dates 2019/2020

    Academic Dates 2019/2020

    ACADEMIC CLASS ADD/DROP DATES
    Term Identifier Part of Term Description Duration of Classes Last Day to Change and Add Classes for registered students Last Day to Drop without “W”
    Last Day to Change from Audit to Credit and Vice Versa
    Last Day to Drop with “W”
    Summer Term 2019

    1 (UG),
    2 (GR)
    Full Term May 6 - July 30, 2019 May 21, 2019 June 5, 2019 July 5, 2019
    9 12-week Term May 30 - August 23, 2019 June 12, 2019 June 26, 2019 July 24, 2019
    A 7-week Term May 6 - June 24, 2019 May 13, 2019 May 21, 2019 June 6, 2019
    D 3-week Term May 6 - May 28, 2019 May 8, 2019 May 10, 2019 May 17, 2019
    E 3-week Term May 30 - June 20, 2019 June 3, 2019 June 5, 2019 June 12, 2019
    B 7-week Term July 2 - August 20, 2019 July 9, 2019 July 17, 2019 August 2, 2019
    F 3-week Term July 2 - July 23, 2019 July 4, 2019 July 8, 2019 July 15, 2019
    G 3-week Term July 25 - August 16, 2019 July 29, 2019 July 31, 2019 August 7, 2019
    4 May 1 - August 31, 2019 May 21, 2019 June 5, 2019 July 5, 2019
    Fall Term 2019

    X/Y Full Year Class September 3, 2019 - April 6, 2020 September 18, 2019 October 31, 2019 February 4, 2020
    1 (UG),
    2 (GR)
    Full Term September 3 - December 3, 2019 September 18, 2019 October 2, 2019 October 31, 2019
    Winter Term 2020

    1 (UG),
    2 (GR)
    Full Term January 6 - April 6, 2020 January 17, 2020 January 31, 2020 March 9, 2020
    Q 4th-year Nursing January 6 - March 13, 2020 January 15, 2020 January 27, 2020 February 24, 2020
    Summer Term 2020

    1 (UG),
    2 (GR)
    Full Term May 4 - July 27, 2020 May 18, 2020 June 2, 2020 July 2, 2020
    9 12-week Term June 4 - August 28, 2020 June 10, 2020 June 24, 2020 July 22, 2020
    A 7-week Term May 11 - June 29, 2020 May 18, 2020 May 26, 2020 June 11, 2020
    D 3-week Term May 11 - June 2, 2020 May 13, 2020 May 15, 2020 May 22, 2020
    E 3-week Term June 4 - June 25, 2020 June 8, 2020 June 10, 2020 June 17, 2020
    B 7-week Term July 6 - August 24, 2020 July 13, 2020 July 21, 2020 August 6, 2020
    F 3-week Term July 6 - July 27, 2020 July 8, 2020 July 10, 2020 July 17, 2020
    G 3-week Term July 29 - August 20, 2020 July 31, 2020 August 4, 2020 August 11, 2020
    4 May 1 - August 31, 2020 May 18, 2020 June 2, 2020 July 2, 2020
    Other Academic Dates

    2019
    May
    Monday, 6 Co-op and Academic Summer term begins
    Friday, 10 Convocation (Faculty of Agriculture)
    Monday, 20 Victoria Day - University closed
    Monday, 27 - Saturday,
    June 1
    Spring Convocations
    July
    Monday, 1 Last day to apply to graduate in the Fall
    University closed in lieu of Canada Day
    Tuesday, 30 Co-op summer academic term ends
    Wednesday, 31 Examinations begin commerce co-op, computer science & engineering
    August
    Monday, 5 Halifax/Dartmouth Natal Day - University closed
    Saturday, 6 Examinations end except commerce co-op
    Wednesday, 14 Examinations end commerce co-op
    September
    Monday, 2 Labour Day - University closed
    Tuesday, 3 Classes begin, fall term
    Wednesday, 18 Last day to apply for honours programs
    October
    Monday, 7 and Tuesday, 8 Fall Convocations
    Monday, 14 Thanksgiving Day - University closed
    November
    Monday, 11 - Friday, 15 Fall Study Week (except students in Co-op Clinicals, or Internships)
    Monday, 11 University closed in lieu of Remembrance Day
    December
    Sunday, 1 Last day to apply to graduate in the Spring
    Tuesday, 3 * Classes end, fall term *
    Tuesday, December 3 - Monday classes will be held
    Thursday, 5 Examinations begin
    Sunday, 15 Examinations end
    Monday, 23 Grades due for courses with formal exams
    2020
    January
    Wednesday, 1 New Year's Day - University closed
    Monday, 6 Classes begin, winter term
    February
    Friday, 7
    Monday, 17 - Friday, 21 Winter Study Week
    Monday, 17 Nova Scotia Heritage Day - University closed
    April
    Monday, 6 ** Classes end, regular session **
    Monday, April 6 - Friday classes will be held
    Wednesday, 8 Examinations begin, regular session
    Friday, 10 Good Friday - University closed
    Friday, 24 Examinations end, regular session
    May
    Friday, 1 Grades due for courses with formal exams
    Monday, 4 Co-op and academic summer term begins
    Monday, 18 Victoria Day - University closed
    Monday, 25 - Sunday, 31 Spring Convocations
    July
    Wednesday, 1 Last day to apply to graduate in October
    University closed in lieu of Canada Day
    Monday, 27 Co-op Summer academic term ends
    Wednesday, 29 Examinations begin, commerce co-op, computer science and engineering
    August
    Monday, 3 Halifax/Dartmouth Natal Day - University closed
    Wednesday, 5 Examinations end, except commerce co-op
    Wednesday, 12 Examinations end, commerce co-op

    * Tuesday, December 3, 2019 - Monday classes will be held
    ** Monday, April 6, 2020 - Friday classes will be held
    General Information

    Definitions

    Definitions

    The following definitions are intended to facilitate an understanding of the calendar and not to define all words and phrases used in the calendar which may have specific meanings.
    Academic Dismissal

    A student’s required withdrawal from a program due to unsatisfactory academic performance.
    Academic Program

    A distinct group of courses and other requirements which lead to eligibility for a degree or other university-awarded credential.
    Academic Terms

    • Fall term: September - December
    • Winter term: January - April
    • Summer term: May - August
    • Regular term: September - April

    Advanced Standing

    Students possessing advanced knowledge of a subject will be encouraged to begin their studies in that subject at a level appropriate to their knowledge, as determined by the department/school/college concerned. However, such students must complete the full number of credit hours required for the particular credential being sought.
    Audit Student

    A student permitted to attend courses but not expected to prepare assignments, write papers, tests or examinations. Credit is not given nor is a mark awarded for courses. Courses appear on the transcript with the notation "Aud". If not already admitted to the University, audit students must apply. Students may register to audit a course only after the first day of courses.
    Candidate

    The term candidate for a doctoral degree is used to identify a student who has fulfilled all the requirements for the PhD except for the submission and defence of the thesis; thus, a candidate will have successfully completed the residency requirement, all course work, qualifying and comprehensive examinations (as applicable), and the thesis proposal defence (if applicable). This status is equivalent to the common terms "all but the thesis" or "all but dissertation" used at some institutions. The term candidate cannot be employed with regard to a Masters degree student.
    Clerkship

    See Internship
    Clinical Practice


  4. #4
    Not sure how helpful that is, I can't see a way to upload a word file. The Heading 2 headers are appearing the same as Heading 3 headers in the sample above.

  5. #5
    Would it be possible to alter my code so it performs the macro on 50 pages at a time and keeps cycling through the document as a means to slow it down or prevent it from locking up?

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,060
    Location
    Try
    Sub RemoveHeadingsWithNoContent()
    Dim oRng As Range
    Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 2"
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
          If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
          If oRng.Paragraphs(1).Next.Range.Style <> "Normal" Then
            oRng.Delete
          End If
          DoEvents
        Loop
      End With
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  7. #7
    Thank you! Your code runs a lot cleaner than mine gmaxey. It will run without crashing Word, but it does appear to get into a never ending loop. With Word still running this at least allows me the ability to test further. I suspect something in the doc is keeping the code from finishing as expected.

  8. #8
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,060
    Location
    Maybe this will help identify the problem:

    Sub RemoveHeadingsWithNoContent()
    Dim oRng As Range
    Dim lngCount As Long
    Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 2"
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
          lngCount = lngCount + 1
          If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
          If lngCount = ActiveDocument.Range.Paragraphs.Count Then
            oRng.Select
            Exit Do
          End If
          If oRng.Paragraphs(1).Next.Range.Style <> "Normal" Then
            oRng.Delete
          End If
          DoEvents
        Loop
      End With
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  9. #9
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    262
    Location
    This one works pretty good but if there is any place in your document where "heading 2" is the style of 4 paragraphs in a row. Like when you have two in a row in your original and they double up you will lose both of the second lines:

    A
    A
    B
    B

    you'll be left with:
    A

    B is entirely lost.

    Sub RemoveRepeatingHeadings()
    Dim oRng As Range
    Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 2"
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
          If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
          If oRng.Paragraphs(1).Range.Style = "Heading 2" _
          And oRng.Paragraphs(1).Next.Range.Style = "Heading 2" Then
          If oRng.Paragraphs(1).Next.Range.Style <> "normal" Then
        oRng.Paragraphs(1).Next.Range.Delete
        '  oRng.Delete
          End If
          End If
          'End If
          DoEvents
        Loop
      End With
    lbl_Exit:
      Exit Sub
    End Sub

    Running a code that would change the style of a blank paragraphs that are heading 2 to normal first would fix this?

  10. #10
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,060
    Location
    I think I read the requirement wrong earlier. You want do delete consecutive Heading 2 text and Heading 2 paragraphs that have no content correct? Try:

    Sub RemoveHeadingsWithNoContent()
    Dim oRng As Range
    Dim lngCount As Long, lngPCount As Long
      
      lngPCount = ActiveDocument.Range.Paragraphs.Count
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 2"
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
          lngCount = lngCount + 1
          If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
          If lngCount = lngPCount Then
            oRng.Select
            Exit Do
          End If
          If oRng.Paragraphs(1).Next.Range.Style = "Heading 2" And _
            oRng.Paragraphs(1).Range.Text = oRng.Paragraphs(1).Next.Range.Text _
            Or oRng.Paragraphs(1).Next.Range.Style = "Heading 2" And Len(oRng.Paragraphs(1).Range.Text) = 1 Then
            oRng.Delete
          End If
          DoEvents
        Loop
      End With
    lbl_Exit:
    So if all this text was Heading 2

    A
    A
    B

    C
    C

    You are left with:

    A
    B
    C
    Greg

    Visit my website: http://gregmaxey.com

  11. #11
    Thank you so much to both of you. The final version that gmaxey posted runs and finishes, but doesn't seem to remove any of the headings I'm trying to remove. The slightly modified version of gmaxey's code that Kilroy posted seems to do exactly what I was hoping it would.

    Thanks again, you have no idea how much work this is going to save me.

  12. #12
    What do you think was the main issue with my original script? If it's not too much trouble, I'm hoping to learn from this experience lol.

  13. #13
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    262
    Location
    Astoneil I ran Gregs code on the sample provided and it worked perfectly. What is remaining that shouldn't be?

  14. #14
    It doesn't seem to remove anything, although I had to add End Sub at the bottom for the code to work. Am I missing anything else?

  15. #15
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    262
    Location
    but doesn't seem to remove any of the headings I'm trying to remove.
    What is remaining hat shouldn't?

  16. #16
    Quote Originally Posted by Kilroy View Post
    What is remaining hat shouldn't?
    The document appears to be unchanged after running Greg's code.

  17. #17
    Kilroy has been very helpful by allowing me to share files and email with them about this. I'm now finding that my Word macros are responding differently than theirs given seemingly exactly the same parameters. I'm going to try more things on my end, and try testing with a different computer if needed. You've both given me a wealth of information and I'm very thankful.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •