求助大神看看这段代码为什么后面的没有创建成功？

zhangzaido

以下代码在当前excel表格中A列已经成功复制成功本目录中的所有word的报告号内容，但是B列的项目名称没有复制是怎么回事？我这是问的chatgpt给写的，自己不懂。，感激不尽，，，，原意是用VBA，检索本目录下所有doc文档，并查找山东信德房估和估价项目名称：这两句话。并复制到当前excel表格中A和B列中。




Sub searchDocFiles()
    Dim strFolder As String
    Dim strFile As String
    Dim objWord As Object
    Dim objDoc As Object
    Dim strContent As String
    Dim i As Integer
   
    strFolder = ThisWorkbook.Path
    strFile = Dir(strFolder & "\*.doc")
   
    '清空A、B两列的数据
    Range("A:B").ClearContents
   
    '设置 i 初始值为 2 （因为第一行是表头）
    i = 2
    Do While Len(strFile) > 0
        Set objWord = CreateObject("Word.Application")
        Set objDoc = objWord.Documents.Open(strFolder & "\" & strFile)
        
        '查找文档中的“山东信德房估”和“估价项目名称：”所在的段落
        With objDoc.Content.Find
            .Text = "山东信德房估"
            If .Execute() Then
                strContent = objDoc.Range.Paragraphs(1).Range.Text
                Range("A" & i).Value = Trim(Split(strContent, vbCr)(0))
            End If
            
            .Text = "估价项目名称："
            If .Execute() Then
                '获取估价项目名称后面一句话的文字内容
                strContent = Split(.Parent.Text, "：")(1)
                '去除空格和换行符
                strContent = Replace(Trim(strContent), vbCr, "")
                Range("B" & i).Value = strContent
            End If
        End With
        
        objDoc.Close False
        objWord.Quit
        
        strFile = Dir()
        '每处理完一个文档，i 自增 1
        i = i + 1
    Loop
End Sub