在两个表

Question

我有一个word文档，其中的表格包含指向其他word文档的超链接，请参见下图。单词文件被分成小组，即每组1个表。

我的问题是有时人们会对格式化感到困惑，例如添加换行符或删除表格之间的换行符（因此我的代码需要它变为1,2,3,4换行而不是2）或更改为了不是字母（很少见，我可以忍受）。

所以最后我的问题，在这种情况下我创建了一个新文件PL_xxxx并且表PL不存在，所以它应该插入一个新表，但是在表之间使用SINGLE换行符，这将插入到另一个表中而不是在表。

' 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函数）

 Sub addList(tableKey As String, filenameTypes As String)
    Dim dict As Object
    Dim addAtEnd As Boolean
    Dim keyArray As Variant
    Dim startSearching As Boolean
    Dim element As Variant
    'Dictionary with all types
    Set dict = getTypes(filenameTypes)

   With dict
   addAtEnd = False
    'extract keys into variant array
    keyArray = .keys
    startSearching = False
    For Each element In keyArray
          'looping untill we find the element we want to add
          If element = tableKey Then
            startSearching = True
           End If


        'Finding the next table after were we want to insert
        If startSearching Then
              If searchAll(CStr(element)) Then
                  addAtEnd = False
                  Exit For
              Else
                  addAtEnd = True
              End If
        End If

    Next

    If addAtEnd Then
        Selection.EndKey Unit:=wdStory
    Else
        Call HelpFunctions.moveCursorUp(CStr(element))
    End If

    Call addTable("UT", tableKey, .item(tableKey), Settings.docUtPath)

    End With

    Set dict = Nothing


 End Sub

最后升级功能显然会向下移动到下一个表格内。

'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

这是可添加的代码，它基本上有一个空的tabley存储在一个单独的文件中。

  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

Answer 1

所以感谢所有输入我现在已经完全修改了代码，它现在正在按需工作，它可能会得到改进，尤其是选择方法。

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