[Закрыто] Форматирование таблиц

Sub FormatCell()
  Dim oCell As Cell
  Dim sCellText As String
  For Each oCell In Selection.Tables(1).Range.Cells
    sCellText = Replace(oCell.Range.Text, "(", "")
    sCellText = Replace(sCellText, ")", "")
    sCellText = Replace(sCellText, ChrW(13) & ChrW(7), "")
    If IsNumeric(sCellText) Then
      If Val(sCellText) > 0 Then
        oCell.Range.ParagraphFormat.RightIndent = CentimetersToPoints(0.1)
      Else
        oCell.Range.ParagraphFormat.RightIndent = CentimetersToPoints(0)
      End If
    End If
  Next
End Sub

Sub FormatCell2()
  Dim oCell As Cell
  Dim sCellText As String
  Dim IsPositive As Boolean
  For Each oCell In Selection.Cells
    sCellText = oCell.Range.Text
    IsPositive = InStr(sCellText, "(") = 0
    sCellText = Replace(oCell.Range.Text, "(", "")
    sCellText = Replace(sCellText, ")", "")
    sCellText = Replace(sCellText, ChrW(13) & ChrW(7), "")
    If IsPositive Then
      oCell.Range.ParagraphFormat.RightIndent = CentimetersToPoints(0.1)
    Else
      oCell.Range.ParagraphFormat.RightIndent = CentimetersToPoints(0)
    End If
  Next
End Sub

Sub FormatCell2()
  Dim oCell As Cell
  Dim CellRng As Range
  Dim sCellText As String
  Dim IsPositive As Boolean
  If Selection.Cells.Count = 0 Then Exit Sub
  Set CellRng = Selection.Cells(1).Range
  'Сжимаем диапазон до запятой
  CellRng.MoveStartUntil ","
  CellRng.MoveEndUntil ",", wdBackward
  'Добавляем табуляцию по разделителю
  Selection.ParagraphFormat.TabStops.ClearAll
  Selection.ParagraphFormat.TabStops.Add CellRng.Information(wdHorizontalPositionRelativeToTextBoundary), wdAlignTabDecimal, wdTabLeaderSpaces
  'Выравнивание абзаца по ширине
  Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
End Sub

Sub AllHeadersTablesWidth()
Dim hRange As Range ' диапазон верхних колонтитулов
Dim ehRange As Range ' диапазон верхних четных колонтитулов
Dim fhRange As Range ' диапазон верхних колонтитулов первых страниц
Dim fRange As Range ' диапазон нижних колонтитулов
Dim efRange As Range ' диапазон нижних четных колонтитулов
Dim ffRange As Range ' диапазон нижних колонтитулов первых страниц
Dim tbl As Table
Dim sec As Section
Dim PageWidth As Single ' Ширина страниц
Dim LeftMargin As Single 'Отступ текста от левого края страницы
Dim RightMargin As Single ' Отступ текста от правого края страницы
Dim TableWidth As Single
Dim CurrentDoc As Document
Set CurrentDoc = ActiveDocument ' присвоение переменной имени текущего документа
Dim i As Integer
i = 1
For Each sec In ActiveDocument.Sections
        PageWidth = CurrentDoc.Sections(i).PageSetup.PageWidth
        LeftMargin = CurrentDoc.Sections(i).PageSetup.LeftMargin
        RightMargin = CurrentDoc.Sections(i).PageSetup.RightMargin
        TableWidth = PageWidth - (LeftMargin + RightMargin)
    Set hRange = sec.Headers(wdHeaderFooterPrimary).Range
    Set ehRange = sec.Headers(wdHeaderFooterEvenPages).Range
    Set fhRange = sec.Headers(wdHeaderFooterFirstPage).Range
    Set fRange = sec.Footers(wdHeaderFooterPrimary).Range
    Set efRange = sec.Footers(wdHeaderFooterEvenPages).Range
    Set ffRange = sec.Footers(wdHeaderFooterFirstPage).Range

    For Each tbl In fhRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
        Application.ScreenRefresh
    Next tbl
    For Each tbl In ffRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
        Application.ScreenRefresh
    Next tbl
    For Each tbl In hRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
        Application.ScreenRefresh
    Next tbl
    For Each tbl In fRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
        Application.ScreenRefresh
    Next tbl
    For Each tbl In ehRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
        Application.ScreenRefresh
    Next tbl
    For Each tbl In efRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
        Application.ScreenRefresh
    Next tbl
    i = i + 1
Next sec
Set fRange = Nothing
Set hRange = Nothing
Set efRange = Nothing
Set ehRange = Nothing
Set fhRange = Nothing
Set ffRange = Nothing
End Sub
Sub AllTablesWidth()
'Выравнивание всех таблиц по ширине текста
' Написан по мотивам макроса А.Кокина из книги
' "Word 2003/2007. Народные советы"
Dim arTable As Table ' определение таблицы как объекта "Таблица"
Dim arCurrentDoc As Document 'определение документа как объект "Документ"
Dim arPageWidth As Single ' Ширина страниц
Dim arLeftMargin As Single 'Отступ текста от левого края страницы
Dim arRightMargin As Single ' Отступ текста от правого края страницы
Dim arTableWidth As Single ' Ширина таблицы
Dim arIndexOfSections As Integer
Dim arMeter As Integer
Dim arStoryRangNumber As Integer
arIndexOfSections = ActiveDocument.Sections.Count
Set arCurrentDoc = ActiveDocument ' присвоение переменной имени текущего документа
For arMeter = 1 To arIndexOfSections ' от первого до последнего раздела
    arPageWidth = arCurrentDoc.Sections(arMeter).PageSetup.PageWidth ' присвоение переменной текущей ширины страницы
    arLeftMargin = arCurrentDoc.Sections(arMeter).PageSetup.LeftMargin ' присвоение переменной значения отступа текста от левого края страницы
    arRightMargin = arCurrentDoc.Sections(arMeter).PageSetup.RightMargin ' присвоение переменной значения отступа текста от правого края страницы
    arTableWidth = arPageWidth - (arLeftMargin + arRightMargin) 'Расчет ширины таблицы исходя из текущих значений переменных
    For Each arTable In ActiveDocument.Sections(arMeter).Range.Tables ' для каждой таблицы в выделенном разделе
        arTable.Rows.Alignment = wdAlignRowCenter 'выравнивание таблицы по центру страницы
        arTable.Rows.LeftIndent = CentimetersToPoints(0) 'измерение ширины в сантиметрах
        arTable.PreferredWidthType = wdPreferredWidthPoints 'тип автоподбора ширины таблицы
        arTable.PreferredWidth = arTableWidth 'собственно задание таблице ее новой ширины
    Next arTable ' работа со следующей таблицей
Next arMeter
End Sub
Sub SingleTablesWidth()
' Изменение ширины любой выбранной таблицы
' Ограничения для колонтитулов - перед таблицей в колонтитуле
' должно быть не больше двух строк (или двух однострочных абзацев)
 Dim arIndexOfSections As Integer
 Dim arN As Integer 'Порядковый номер раздела
 Dim arPageWidth As Single ' Ширина страниц
 Dim arLeftMargin As Single 'Отступ текста от левого края страницы
 Dim arRightMargin As Single ' Отступ текста от правого края страницы
 Dim arSingleTableWidth As Single
 Dim arCurrentDoc As Document
 Dim arTable As Table
 Set arCurrentDoc = ActiveDocument ' присвоение переменной имени текущего документа
    arN = Selection.Information(wdActiveEndSectionNumber) ' Номер колонтитула, первый изначально
    arPageWidth = arCurrentDoc.Sections(arN).PageSetup.PageWidth
    arLeftMargin = arCurrentDoc.Sections(arN).PageSetup.LeftMargin
    arRightMargin = arCurrentDoc.Sections(arN).PageSetup.RightMargin
    arSingleTableWidth = arPageWidth - (arLeftMargin + arRightMargin)
    If Selection.Information(wdWithInTable) Then
        Set arTable = Selection.Tables(1)
        arTable.Rows.Alignment = wdAlignRowCenter 'выравнивание таблицы по центру страницы
        arTable.Rows.LeftIndent = CentimetersToPoints(0) 'измерение ширины в сантиметрах
        arTable.PreferredWidthType = wdPreferredWidthPoints 'тип автоподбора ширины таблицы
        arTable.PreferredWidth = arSingleTableWidth 'собственно изменение ширины
    Else
        Selection.MoveDown Unit:=wdLine, Count:=1
            If Selection.Information(wdWithInTable) Then
                Set arTable = Selection.Tables(1)
                arTable.Rows.Alignment = wdAlignRowCenter 'выравнивание таблицы по центру страницы
                arTable.Rows.LeftIndent = CentimetersToPoints(0) 'измерение ширины в сантиметрах
                arTable.PreferredWidthType = wdPreferredWidthPoints 'тип автоподбора ширины таблицы
                arTable.PreferredWidth = arSingleTableWidth 'собственно изменение ширины
            Else
            Selection.MoveDown Unit:=wdLine, Count:=1
                    If Selection.Information(wdWithInTable) Then
                        Set arTable = Selection.Tables(1)
                            arTable.Rows.Alignment = wdAlignRowCenter 'выравнивание таблицы по центру страницы
                            arTable.Rows.LeftIndent = CentimetersToPoints(0) 'измерение ширины в сантиметрах
                            arTable.PreferredWidthType = wdPreferredWidthPoints 'тип автоподбора ширины таблицы
                            arTable.PreferredWidth = arSingleTableWidth 'собственно изменение ширины
                    Else
            Selection.MoveUp Unit:=wdLine, Count:=2
                    End If
            End If
End If
End Sub