Вставьте таблицу в слово между двумя таблицами

Question

У меня есть документ с текстом, содержащий гиперссылки на другие текстовые документы, см. Изображение ниже. Документы с текстом привязаны к группам, т. Е. По 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 

Ниже приведен код, который Seach если PL существует, который будет возвращать ложь в этом случае:

' 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 

Вот код, который на самом деле цифры где можно поместить таблицу и добавить ее, и вот в чем проблема (переписывайте, чтобы перебрать таблицы или изменить функцию подъема)

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 

И вот код добавочной таблицы, который в основном имеет пустую столовую, хранящуюся в отдельном файле.

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