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

[nathanfsu]

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?