Vba 在两个表之间插入word中的表

我有一个word文档，其中的表格包含指向其他word文档的超链接，请参见下图。word文档被分类为多个组，即每个组有一个表

我的问题是，有时人们会弄乱格式，比如在表之间添加一个换行符或删除一个换行符（因此它会变成1,2,3,4个换行符，而不是我的代码所要求的2个），或者将顺序更改为非字母顺序（罕见，我可以接受）

最后，我的问题是，在本例中，我创建了一个新的文档PL_xxxx，而表PL不存在，因此它应该插入一个新表，但是表之间有一个换行符，这会插入到另一个表中，而不是表之间

' Now move up two lines, beyond the table end
                Selection.MoveUp Unit:=wdLine, Count:=2

那么，我如何确保表之间的换行符总是一致的呢？有没有办法删除表之间的所有换行符，然后重新创建它们，然后插入表？或者我可以通过某种方式循环浏览文档中的所有表吗？或者是否有其他方法来确保不发生这样的错误

这是我的主要代码：

'here we alter the docout tables
If Not searchAll(dokType) Then
    Call addList(dokType, Settings.documentTypeFile)
    docNumber = "01"
Else

下面是我搜索PL是否存在的代码，在这种情况下将返回false：

' Moves cursor to the place the given string is found, or replace it
  Function searchAll(searchText As String, Optional replaceText As String = "GGG") As Boolean
    'default false
    searchAll = False


    If Not replaceText = "GGG" Then

        With ActiveDocument.Range.Find
             .Text = searchText
             .forward = True
             .Wrap = wdFindContinue
             .Format = True
             .MatchCase = True
             .MatchWholeWord = True
            .Replacement.Text = replaceText
            If .Execute(Replace:=wdReplaceAll) Then
                searchAll = True
            End If
        End With
    'just searching
    Else
         With Selection.Find
             .Text = searchText
             .forward = True
             .Wrap = wdFindContinue
             .Format = True
             .MatchCase = True
             .MatchWholeWord = True
             If .Execute Then
                searchAll = True
            End If
        End With
    End If


End Function

下面是实际计算表的放置位置和添加表的代码，这里是问题所在（重写以循环遍历表或修改moveup函数）

最后是上移函数，很明显，它在下一个表中上移了很多

'move cursor up
  Function moveCursorUp(searchText As String)

    If Not searchAll(searchText) Then
        MsgBox "Failed to move cursor"
    Else
         'Selection.Tables(1).Select

        If Selection.Information(wdWithInTable) Then
            Selection.Tables(1).Range.Select
            Selection.Collapse 1

            ' Now move up two lines, beyond the table end
            Selection.MoveUp Unit:=wdLine, Count:=2
        End If
        'Selection.Collapse WdCollapseDirection.wdCollapseStart
    End If

  End Function

这是addtable代码，它基本上有一个空表，存储在一个单独的文件中

  Function addTable(typeOfTable As String, category As String, description As String, templateFolder As String)
        'Insert out table
        If UCase(typeOfTable) = "UT" Then
            Selection.InsertFile FileName:=templateFolder + "\Doklistut.doc", Range:="", _
            ConfirmConversions:=False, link:=False, Attachment:=False
        'insert inn table
        ElseIf UCase(typeOfTable) = "INN" Then
            Selection.InsertFile FileName:=templateFolder + "\Doklistinn.doc", Range:="", _
            ConfirmConversions:=False, link:=False, Attachment:=False
        Else
            MsgBox "wrong argument given: either inn or ut is allowed"
            Exit Function
        End If

        'Replace the DT with the category
         If Not searchAll("DT", category) Then
             MsgBox "Failed to replace category in table"
         End If

          'Replace the Dokumenttype with the category
         If Not searchAll("Dokumenttype", description) Then
             MsgBox "Failed to replace document type in table"
         End If
  End Function

---

因此，感谢所有的输入，我现在已经完全修改了代码，它现在可以按预期工作，它可能会得到改进，特别是选择方法

Sub addList(tableKey As String, tableDescription As String)
    Selection.EndKey Unit:=wdStory
    Call addTable(tableKey, tableDescription)
    Call SortTables
 End Sub

Sub Deleemptylines()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "^p"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub SortTables()
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim blnSwapped As Boolean

    Call Deleemptylines
    iMin = 1
    iMax = ActiveDocument.Tables.Count - 1

    Do
        blnSwapped = False
        For i = iMin To iMax

          If ActiveDocument.Tables(i).Cell(1, 1).Range.Text > ActiveDocument.Tables(i + 1).Cell(1, 1).Range.Text Then

                ActiveDocument.Tables(i).Range.Cut

                ActiveDocument.Tables(i).Select
                Selection.Collapse WdCollapseDirection.wdCollapseEnd
                Selection.Paragraphs.Add
                Selection.Paragraphs.Add
                Selection.MoveDown Unit:=wdLine, Count:=1
                Selection.MoveUp Unit:=wdLine, Count:=1
                Selection.Paste
                blnSwapped = True
            End If
        Next i
        iMax = iMax - 1
    Loop Until Not blnSwapped

    Call Deleemptylines
End Sub


  Function addTable(category As String, description As String)
        'Insert out table
        Selection.InsertFile FileName:=Settings.docUtPath + "\Doklistut.doc", Range:="", _
        ConfirmConversions:=False, link:=False, Attachment:=False

        'Replace the DT with the category
         If Not searchAll("DT", category) Then
             MsgBox "Failed to replace category in table"
         End If

        'Replace the Dokumenttype with the category
         If Not searchAll("Dokumenttype", description) Then
             MsgBox "Failed to replace document type in table"
         End If
  End Function

---

嗯，您向我们展示的代码与操作表无关，但与处理表无关。AddTable丢失，例如，您的代码“调用”。不知道什么是“桌面钥匙”。。。你想要做的一个真正的大问题是你使用选择而不是对象，比如范围和表格。我可以告诉你的一件事是，表格之间必须至少有一个段落标记，否则Word会将两个表格合并成一个表格，你不希望这样。为了保持一致，我会确保表格之间只有一个段落。如果视觉上需要更多空间，请使用SpaceBefore或SpaceAfter（使用样式！）设置段落格式。是的，在文档中循环表是可能的，但是由于您没有向我们展示任何与表相关的代码，所以只能这样说。FWIW（a）我同意Cindy Meister的评论，但是（b）IMO真正的问题是您对用户的操作有多大的控制权。如果您有很多控件，并且您的用户都在使用最新版本的Windows Word，那么确保表之间存在特定的、可识别的间隙的一种方法可能是在它们之间插入一个不可删除的内容控件。用户可能会意外地在表之间添加额外的空间，但删除控件会更困难。等等…很抱歉，我忘记了addtable代码，我现在编辑原来的帖子。我正在按照建议重写以使用object。稍后将发布我的进度：）运行当前代码的问题在哪里？

Sub addList(tableKey As String, tableDescription As String)
    Selection.EndKey Unit:=wdStory
    Call addTable(tableKey, tableDescription)
    Call SortTables
 End Sub

Sub Deleemptylines()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "^p"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub SortTables()
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim blnSwapped As Boolean

    Call Deleemptylines
    iMin = 1
    iMax = ActiveDocument.Tables.Count - 1

    Do
        blnSwapped = False
        For i = iMin To iMax

          If ActiveDocument.Tables(i).Cell(1, 1).Range.Text > ActiveDocument.Tables(i + 1).Cell(1, 1).Range.Text Then

                ActiveDocument.Tables(i).Range.Cut

                ActiveDocument.Tables(i).Select
                Selection.Collapse WdCollapseDirection.wdCollapseEnd
                Selection.Paragraphs.Add
                Selection.Paragraphs.Add
                Selection.MoveDown Unit:=wdLine, Count:=1
                Selection.MoveUp Unit:=wdLine, Count:=1
                Selection.Paste
                blnSwapped = True
            End If
        Next i
        iMax = iMax - 1
    Loop Until Not blnSwapped

    Call Deleemptylines
End Sub


  Function addTable(category As String, description As String)
        'Insert out table
        Selection.InsertFile FileName:=Settings.docUtPath + "\Doklistut.doc", Range:="", _
        ConfirmConversions:=False, link:=False, Attachment:=False

        'Replace the DT with the category
         If Not searchAll("DT", category) Then
             MsgBox "Failed to replace category in table"
         End If

        'Replace the Dokumenttype with the category
         If Not searchAll("Dokumenttype", description) Then
             MsgBox "Failed to replace document type in table"
         End If
  End Function