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

What is the point of the copying? Your outline says nothing about what you want to do with what you've copied.

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

Quote:

---

Originally Posted by macropod

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

Code:

---

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

---

Quote:

---

Originally Posted by gmaxey

Code:

---

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

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:

Code:

---

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

---

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?

​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.

Code:

---

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?

Simply wrapping code tags around unstructured code does nothing to improve its legibility...

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.

Code:

---

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

---

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.