VBA循环在第一次迭代后冻结/崩溃word

试图确定word文档中每个表的总宽度。第一次迭代后，脚本挂起，Microsoft Word停止响应

Sub fixTableAlignment()
    For Each tTable In ActiveDocument.Tables
      Dim tRng As Range
      Dim sngWdth As Single
      Set tRng = tTable.Cell(1, 1).Range
      sngWdth = -tRng.Information(wdHorizontalPositionRelativeToPage)
      Do While tRng.Cells(1).RowIndex = 1
        tRng.Move unit:=wdCell, Count:=1
      Loop
      tRng.MoveEnd wdCharacter, -1
      sngWdth = sngWdth + tRng.Information(wdHorizontalPositionRelativeToPage)
      MsgBox PointsToInches(sngWdth)
    Next tTable
  End Sub

---

所提供的代码不适用于由一行组成的表。此

执行While

循环：

Do While tRng.Cells(1).RowIndex = 1
    tRng.Move unit:=wdCell, Count:=1
Loop

当我们找到一个不在第1行的单元格时发生。如果只有一行，则每个单元格都位于第1行

如果移动不成功，

Move

方法返回0，因此应该可以：

Dim lngSuccess As Long

For Each ttable In ThisDocument.Tables
  Set tRng = ttable.Cell(1, 1).Range
  sngWdth = -tRng.Information(wdHorizontalPositionRelativeToPage)

  ' Any non-zero value will do here
  lngSuccess = 1
  Do While tRng.Cells(1).RowIndex = 1 And lngSuccess <> 0
    lngSuccess = tRng.Move(unit:=wdCell, Count:=1)
  Loop

  tRng.MoveEnd wdCharacter, -1
  sngWdth = sngWdth + tRng.Information(wdHorizontalPositionRelativeToPage)
  MsgBox PointsToInches(sngWdth)
Next tTable

---

您是否尝试过使用

F8

单步执行代码？如果您将两条

Dim

语句移动到

上方，对每条
语句是否有帮助？通过我的测试，它不会导致问题，但是没有理由继续重新声明它们。Sean，不幸的是，我需要它在一次运行中工作。道格，我有：/你是说这个脚本对你来说还可以吗？非常感谢你们的回复！对不起，不，我没那么说。我做了一个简单的测试——不是你的代码——认为这是Dim在一个循环中，但它工作得很好。我认为@seanschere建议用
F8
一次调试一行代码是一个好建议。这太棒了！谢谢你，巴罗克。我还有最后一个问题。。该脚本在只有一行的表上抛出错误-我对VBA非常陌生，如何处理Do While语句的此异常？“请求的集合成员不存在。”在发布答案之前，我在单行表上对其进行了测试。它在Word 2003中工作正常。我刚刚又测试了一次，它没有产生错误。但是，当它移回最后一个单元格时，它会报告单行表的错误长度。我将编辑我的答案以更正此问题实际上它会移回最后一个字符，但我的表格中每个单元格有一个字符
Option Explicit

Sub fixTableAlignment()
    Dim tTable As Table
    Dim cCell As Cell
    Dim sngWdth As Single
    Dim bFinished As Boolean

    For Each tTable In ThisDocument.Tables
        Set cCell = tTable.Cell(1, 1)
        sngWdth = 0

        ' Can't just check the row index as cCell
        ' will be Nothing when we run out of cells
        ' in a single-row table. Can't check for
        ' Nothing and also check the row index in
        ' the Do statement as VBA doesn't short-circuit
        bFinished = False
        Do Until bFinished
            sngWdth = sngWdth + cCell.Width
            Set cCell = cCell.Next

            If (cCell Is Nothing) Then
                bFinished = True
            ElseIf (cCell.RowIndex <> 1) Then
                bFinished = True
            End If
        Loop

        MsgBox PointsToInches(sngWdth)
    Next tTable
End Sub