試試下面的程式碼，在網上找的

Sub 宏1()

Dim wordapp As Object

Dim mydoc

Dim mypath$, myname$

Dim wdRng As Object

Dim pos1%, pos2% "定義找到的欄位的首位位置

Application.DisplayAlerts = False

Set wordapp = CreateObject("word.application")

mypath = ThisWorkbook.Path & ""

myname = Dir(mypath & "*.doc*")

Set mydoc = wordapp.Documents.Open(mypath & myname)

Set wdRng = mydoc.Range

wdRng.Find.Execute ("（一）")

pos1 = wdRng.Start

Set wdRng = mydoc.Range

wdRng.Find.Execute ("五、")

pos2 = wdRng.Start

mydoc.Range(pos1, pos2).Copy "選中找到的兩個欄位中間的內容

mydoc.Close False

wordapp.Quit

Worksheets("Sheet2").Select

Range("A1").Select

ActiveSheet.Paste

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub