Consulting

Results 1 to 13 of 13

Thread: I need help to copy content between two headings in word - vba

  1. #1

    I need help to copy content between two headings in word - vba

    Good night.
    I need 3 VBA in word.
    First: to copy the title of heading X
    Second: to copy between heading X to X+1
    Third to go to the new heading

    Ty

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,125
    Location
    What is the point of the copying? Your outline says nothing about what you want to do with what you've copied.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,125
    Location
    Cross-posted at: https://www.msofficeforums.com/word-...t-heading.html
    Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq...._new_faq_item3
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  4. #4
    Quote Originally Posted by macropod View Post
    What is the point of the copying? Your outline says nothing about what you want to do with what you've copied.
    I need to transform my headings in a question and answer game in another software. So I would like to automate

    For example

    HeadStyle 1: Question 1: aaaaa?

    Head Style 2: ans
    Head Style 2: ans
    Head Style 2: ans

    HeadStyle 1: Question 2: bbbb?
    Head Style 2: ans
    Head Style 2: ans
    no style text: ans

    I want first to select current heading: "Question 1: aaaaa?" then copy --- after that I'll paste with autohotkey to another software.
    Then, I would like to copy the answer:
    Head Style 2: ans
    Head Style 2: ans
    no style text: ans
    Then to repeat the process I would like to select next heading with headstyle 1: Question 2: bbbb?

    Sorry for the double posting, my mistake

  5. #5
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,195
    Location
    Sub ScratchMacro()
    'A basic Word macro coded by Greg Maxey
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 1"
        While .Execute
          Do
            oRng.MoveEnd wdParagraph, 1
          Loop Until oRng.Paragraphs.Last.Range.Style = "Heading 1" Or oRng.Paragraphs.Last.Range.End = ActiveDocument.Range.End
          oRng.MoveEnd wdParagraph, -1
          oRng.Copy
          'Do whatever with the complied content here.
          oRng.Collapse wdCollapseEnd
        Wend
      End With
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  6. #6
    Quote Originally Posted by gmaxey View Post
    Sub ScratchMacro()
    'A basic Word macro coded by Greg Maxey
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 1"
        While .Execute
          Do
            oRng.MoveEnd wdParagraph, 1
          Loop Until oRng.Paragraphs.Last.Range.Style = "Heading 1" Or oRng.Paragraphs.Last.Range.End = ActiveDocument.Range.End
          oRng.MoveEnd wdParagraph, -1
          oRng.Copy
          'Do whatever with the complied content here.
          oRng.Collapse wdCollapseEnd
        Wend
      End With
    lbl_Exit:
      Exit Sub
    End Sub
    Thanks man. But it did not work. It copied last paragraph, with the title with answer.

    I'm tying one Sub to copy the title of X "heading 1", then another sub to copy everything is wrote in between X heading 1 and X+1 heading 1 except the title.

    Example

    My word:
    "Style Heading 1" Question number 1:
    wor
    wor
    "Style Heading 1" Question number 2
    asn
    asn
    "Style Heading 1" Question number 3
    asn

    FunctionCopyTitle ( X=2) ..:
    Clipboard Return: "Style Heading 1" Question number 2:

    FunctionCopyAnswer ( X=2) ..:
    Clipboard Return:
    asn
    asn

  7. #7
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,195
    Location
    I have no idea what you are trying to do and your examples don't help. What is "wor". If you only want the content between the Heading 1 styles then:

    Sub ScratchMacro()
    'A basic Word macro coded by Greg Maxey
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Style = "Heading 1"
        While .Execute
          oRng.Move wdParagraph, 1
          Do
            oRng.MoveEnd wdParagraph, 1
            oRng.Select
          Loop Until oRng.Paragraphs.Last.Range.Style = "Heading 1" Or oRng.Paragraphs.Last.Range.End = ActiveDocument.Range.End
          If Not oRng.End = ActiveDocument.Range.End Then oRng.MoveEnd wdParagraph, -1
          oRng.Copy
          MsgBox oRng.Text
          'Do whatever with the complied content here.
          oRng.Collapse wdCollapseEnd
        Wend
      End With
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  8. #8
    Sub Selecionarperguntas()

    Selection.MoveRight Unit:=wdWord, Count:=1
    Application.ScreenUpdating = False

    palavras = 0
    Do Until Selection.Paragraphs(1).Style.NameLocal = "Título 1"
    'Do Until ActiveDocument.Paragraphs(1).Style = "Título 1"
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
    Loop


    palavras = 0
    Do Until Selection.Words(1).Style.NameLocal <> "Título 1"
    palavras = palavras + 1

    Selection.MoveRight Unit:=wdWord, Count:=1
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Loop

    Selection.MoveLeft Unit:=wdWord, Count:=palavras, Extend:=wdExtend
    If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Application.ScreenUpdating = True


    Selection.Copy
    fim:
    Application.ScreenUpdating = True
    End Sub

    Sub Selecionarresposta()

    Application.ScreenUpdating = False
    palavras = 0
    Do Until Selection.Words(1).Style.NameLocal <> "Título 1"

    Selection.MoveRight Unit:=wdWord, Count:=1
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Loop

    Do Until Selection.Words(1).Style.NameLocal = "Título 1"

    Selection.MoveRight Unit:=wdWord, Count:=1
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    palavras = palavras + 1
    Loop

    fim:
    Selection.MoveLeft Unit:=wdWord, Count:=palavras, Extend:=wdExtend
    Selection.Copy
    Application.ScreenUpdating = True

    End Sub

    I did this macro, but sometimes it is too slow, anyway to improve?

  9. #9
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,125
    Location
    ​nathanfsu: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  10. #10
    Sub Selecionarperguntas()
    
    Selection.MoveRight Unit:=wdWord, Count:=1
    Application.ScreenUpdating = False
    
    palavras = 0
    Do Until Selection.Paragraphs(1).Style.NameLocal = "Título 1"
    'Do Until ActiveDocument.Paragraphs(1).Style = "Título 1"
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdMove
    Loop
    
    
    palavras = 0
    Do Until Selection.Words(1).Style.NameLocal <> "Título 1"
    palavras = palavras + 1
    
    Selection.MoveRight Unit:=wdWord, Count:=1
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Loop
    
    Selection.MoveLeft Unit:=wdWord, Count:=palavras, Extend:=wdExtend
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Application.ScreenUpdating = True
    
    
    Selection.Copy
    fim:
    Application.ScreenUpdating = True
    End Sub
    
    Sub Selecionarresposta()
    
    Application.ScreenUpdating = False
    palavras = 0
    Do Until Selection.Words(1).Style.NameLocal <> "Título 1"
    
    Selection.MoveRight Unit:=wdWord, Count:=1
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    Loop
    
    Do Until Selection.Words(1).Style.NameLocal = "Título 1"
    
    Selection.MoveRight Unit:=wdWord, Count:=1
    'If Linha() >= ActiveDocument.Paragraphs.Count Then GoTo fim
    palavras = palavras + 1
    Loop
    
    fim:
    Selection.MoveLeft Unit:=wdWord, Count:=palavras, Extend:=wdExtend
    Selection.Copy
    Application.ScreenUpdating = True
    
    End Sub
    any help in how to improve the macro speed?

  11. #11
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,125
    Location
    Simply wrapping code tags around unstructured code does nothing to improve its legibility...
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  12. #12
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,195
    Location
    You have been given plenty to work with yet you insist on coming back here with a mess of Selection code. For the process of selecting text between Heading 1, something like this (I still have no clue what you ultimately want to do. BTW, moving by words will always be slower than moving by paragraph unless of course the paragraphs have only one word.

    Sub TextBetweenHeading1()
    'A basic Word macro coded by Greg Maxey
    Dim oRng As Range
      Selection.Collapse wdCollapseEnd
      Set oRng = Selection.Range
      oRng.Collapse wdCollapseEnd
      Do While oRng.Paragraphs(1).Style = "Heading 1"
        oRng.Move wdParagraph, 1
      Loop
      Do
        oRng.MoveEnd wdParagraph, 1
        oRng.Select
      Loop Until oRng.Paragraphs.Last.Range.Style = "Heading 1" Or oRng.Paragraphs.Last.Range.End = ActiveDocument.Range.End
      If Not oRng.End = ActiveDocument.Range.End Then oRng.MoveEnd wdParagraph, -1
      Do
        oRng.MoveStart wdParagraph, -1
        oRng.Select
      Loop Until oRng.Paragraphs(1).Range.Style = "Heading 1" Or oRng.Paragraphs(1).Range.Start = ActiveDocument.Range.Start
      If Not oRng.Start = ActiveDocument.Range.Start Or oRng.Paragraphs(1).Style = "Heading 1" Then oRng.MoveStart wdParagraph, 1
      oRng.Select
      oRng.Copy
    lbl_Exit:
      Exit Sub
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  13. #13
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,125
    Location
    Also cross-posted at: https://stackoverflow.com/questions/...gs-in-word-vba
    Since you've ignored this forum's cross-posting rules, by failing to provide the required link, I am closing this thread.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

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