运行VBA按工单号匹配Excel数据导出到Word时Excel崩溃如何解决

核心问题是行号递增逻辑位置错误：你的iRow = iRow + 1代码写在了工单号匹配成功的If代码块内部，只有当当前行的工单号和D26输入的内容匹配时，才会执行行号+1的操作。
如果要查询的工单号不在数据库首行（也就是你设定的起始行第2行），If条件永远不成立，iRow始终为2，程序会进入死循环反复判断第2行数据，最终导致Excel无响应崩溃。而当工单号刚好在第2行时，匹配成功后会执行行号递增+退出循环，所以运行正常。
另外你用了后期绑定调用Word，代码中直接使用Word内置常量wdGoToBookmark会无法识别，也可能引发未知异常。

按照以下步骤修改代码即可：

1. 把iRow = iRow + 1移到If判断块之外、Loop之前，保证每循环一次无论是否匹配都会向下遍历一行
2. 手动定义Word常量wdGoToBookmark，适配后期绑定场景
3. 新增匹配结果判断，遍历完所有数据都没找到对应工单号时给用户明确提示，避免误报成功
4. 把wd.Visible = False移到Word应用初始化之后，减少不必要的窗口显示

修复后完整代码如下：

Sub GenerateWordDoc()
    Dim wd As Object 'Word Application
    Dim wdDOC As Object 'word document
    Dim iRow As Long 'Variable to hold the starting row and loop through all records in database
    Dim sh As Worksheet 'worksheet variable to refer  to where database is stored
    Dim WorksOrder As String
    Dim matchFound As Boolean
    ' 手动定义Word常量，适配后期绑定
    Const wdGoToBookmark As Long = -1

    'Start word as new document
    Set wd = CreateObject("Word.Application")
    wd.Visible = False ' 提前设置Word不可见

    'Get user entered WorksOrder Number
    WorksOrder = ThisWorkbook.Sheets("Database").Range("D26").Value

    'Set worksheet
    Set sh = ThisWorkbook.Sheets("Database")
    iRow = 2 'row in which data starts from in database
    matchFound = False

    Do While sh.Range("A" & iRow).Value <> "" 'loop through until no data is found (last row of database)
        If WorksOrder = sh.Range("D" & iRow).Value Then
            matchFound = True
            'opening word template
            Set wdDOC = wd.Documents.Add("T:\mageeg\TEST DATA  INSPECTION SCHEDULE Issue 3.docx")

            'code to insert values from database to bookmarks in word
            wd.Selection.GoTo what:=wdGoToBookmark, Name:="PartNo"
            wd.Selection.TypeText Text:=sh.Range("C" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="Serial"
            wd.Selection.TypeText Text:=sh.Range("E" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="ModelNo"
            wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="WorksOrderNo"
            wd.Selection.TypeText Text:=sh.Range("D" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="MaterialNo"
            wd.Selection.TypeText Text:=sh.Range("F" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="SerialNo"
            wd.Selection.TypeText Text:=sh.Range("E" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="ModelNo2"
            wd.Selection.TypeText Text:=sh.Range("B" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="Type"
            wd.Selection.TypeText Text:=sh.Range("H" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="Size"
            wd.Selection.TypeText Text:=sh.Range("I" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="WKPRESS"
            wd.Selection.TypeText Text:=sh.Range("J" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="SerialNumber"
            wd.Selection.TypeText Text:=sh.Range("G" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="CertDate"
            wd.Selection.TypeText Text:=sh.Range("K" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="BatchNo"
            wd.Selection.TypeText Text:=sh.Range("L" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="JobNo"
            wd.Selection.TypeText Text:=sh.Range("M" & iRow).Value

            wd.Selection.GoTo what:=wdGoToBookmark, Name:="DateOfManufacture"
            wd.Selection.TypeText Text:=Format(sh.Range("N" & iRow).Value, "mmm-yy")

            'code to delete the existing bookmarks from wordfile
            On Error Resume Next
            wdDOC.Bookmarks("PartNo").Delete
            wdDOC.Bookmarks("SerialNo").Delete
            wdDOC.Bookmarks("ModelNo").Delete
            wdDOC.Bookmarks("WorksOrderNo").Delete
            wdDOC.Bookmarks("MaterialNo").Delete
            wdDOC.Bookmarks("Serial").Delete
            wdDOC.Bookmarks("ModelNo2").Delete
            wdDOC.Bookmarks("Type").Delete
            wdDOC.Bookmarks("Size").Delete
            wdDOC.Bookmarks("WKPRESS").Delete
            wdDOC.Bookmarks("SerialNumber").Delete
            wdDOC.Bookmarks("CertDate").Delete
            wdDOC.Bookmarks("BatchNo").Delete
            wdDOC.Bookmarks("JobNo").Delete
            wdDOC.Bookmarks("DateOfManufacture").Delete
            On Error GoTo 0 ' 恢复错误捕获

            'save file with new name
            wdDOC.SaveAs2 (ThisWorkbook.Path & "\" & sh.Range("D" & iRow).Value & ".docx")

            'close the word file
            wdDOC.Close
            Set wdDOC = Nothing

            Exit Do ' 匹配到唯一工单号直接退出循环
        End If
        iRow = iRow + 1 ' 移到If块外，每次循环都递增行号
    Loop

    wd.Quit 'close MS Word
    Set wd = Nothing 'Release memory allocated to WD

    If matchFound Then
        MsgBox "Inspection Test Sheet Created"
    Else
        MsgBox "未找到对应工单号的记录，请检查D26输入内容"
    End If
End Sub

内容的提问来源于stack exchange，提问作者grey717