Ок. Попробуйте мой вариант. Подключите этот шаблон через Надстройки, откройте нужный документ, нажмите Alt+S (или Alt+F8 и выполнить макрос SortTables). После этого, по идее, должен создаться новый документ с таблицами, отсортированными по возрастанию суммы.
Макрос не ахти какой, на скорую руку. Буду рад, если помогут оптимизировать.
Option Explicit
Public Type Tbl
Start As Long
Sum As Single
End Type
Public Sub SortTables()
Dim ar() As Tbl, oNewDoc As Document, oCurrDoc As Document
Dim t As Tbl
ReDim ar(0)
Set oCurrDoc = ActiveDocument
With oCurrDoc.Range.Find
.Text = "<[0-9]@-[0-9]{2}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
While .Execute
t.Start = .Parent.Tables(1).Range.Start
t.Sum = CSng(Replace(.Parent.Text, "-", ","))
ar(UBound(ar)) = t
ReDim Preserve ar(UBound(ar) + 1)
Wend
End With
ReDim Preserve ar(UBound(ar) - 1)
Dim i As Long, j As Long, temp As Tbl
For i = 0 To UBound(ar) - 1
For j = i + 1 To UBound(ar)
If ar(i).Sum > ar(j).Sum Then
temp = ar(i)
ar(i) = ar(j)
ar(j) = temp
End If
Next j, i
Set oNewDoc = Documents.Add
Dim oRng As Range
For i = 0 To UBound(ar)
oCurrDoc.Range(ar(i).Start, ar(i).Start).Tables(1).Range.Copy
oNewDoc.Paragraphs.Last.Range.PasteAndFormat (wdFormatOriginalFormatting)
If i < UBound(ar) Then oNewDoc.Paragraphs.Last.Range.InsertBreak wdPageBreak
Next i
End Sub
Post's attachmentsSorPayroll.dot 34 Кб, 2 скачиваний с 2014-02-14
You don't have the permssions to download the attachments of this post.
Лучше день потерять — потом за пять минут долететь!