Sub AAA() Dim FilePath As String '要读取的文件路径 Dim S1 As String '文档的内容 Dim S2 As String '提取到的内容 Dim Ar As Variant '用于保存最终结果 Dim L1 As Long '记录当前查找到的字符位置 FilePath = Application.GetSaveAsFilename(fileFilter:="Word文档,*.doc;*.docx") If FilePath = "False" Then MsgBox "您没有选择文件,将退出程序。": Exit Sub With CreateObject("word.application") With .Documents.Open(FilePath, True, True) S1 = .Content .Close False End With .Quit End With L1 = InStr(S1, "<") '第一个 < 位置 Do Until L1 = 0 If Len(S2) <> 0 Then S2 = S2 & "Crazy0qwer" & Mid(S1, L1 + 1, InStr(L1, S1, ">") - L1 - 1) Else S2 = Mid(S1, L1 + 1, InStr(L1, S1, ">") - L1 - 1) End If L1 = InStr(L1 + 1, S1, "<") Loop Ar = Split(S2, "Crazy0qwer") Range("A1").Resize(UBound(Ar) + 1) = Application.Transpose(Ar)End Sub