如何用VBA使Word表格整齐地适合页面

Question

我想在 Word 表格上执行以下操作： AutoFitBehavior(wdAutoFitWindow) 但是：

1. 我不希望单元格中的文本换行（因此我使用 Rows.HeightRule = wdRowHeightExactly）。
2. 如果文本太大而表格无法适应页面，我希望最大的单元格应用 FitText 直到它
3. 需要处理包含合并单元格的表格

我将发布我自己的表格尝试作为答案，但我想知道是否有更好的方法？

Answer 1

我预先计算了所需的表格宽度，并将其传递到以下 Fit 函数中：

Sub Fit(pTable As Word.Table, pWidth As Integer)
    Dim oCell As Word.Cell
    Dim oRefCell As Word.Cell
    Dim oDict As New Scripting.Dictionary
    Dim nThisColumnWidth As Double
    Dim nTableWidth As Double
    Dim oToFit As New Collection

    Call pTable.AutoFitBehavior(wdAutoFitContent)

    For Each oCell In pTable.Range.Cells
        If Len(oCell.Range.Text) > 8 Then
            Call oDict.Add(oCell, Len(oCell.Range.Text))
        End If
    Next
    Set oDict = SortDict(oDict)

    For Each oCell In oDict
        Let nTableWidth = 0
        For Each oRefCell In pTable.Rows(1).Cells
            Let nTableWidth = nTableWidth + oRefCell.Width
        Next
        If nTableWidth < pWidth Then
            Exit For
        End If
        oCell.Range.Font.Hidden = True
        Call oToFit.Add(oCell)
        DoEvents
    Next
    For Each oCell In oToFit
        oCell.FitText = True
        oCell.Range.Font.Hidden = False
    Next

    Call pTable.AutoFitBehavior(wdAutoFitWindow)
End Sub
Function SortDict(ByRef oDict)
    Dim i As Integer
    Dim j As Integer
    Dim oKeys

    oKeys = oDict.Keys
    Call QuickSort(oDict, oKeys)

    Set SortDict = New Scripting.Dictionary

    For i = UBound(oKeys) To LBound(oKeys) Step -1
        Call SortDict.Add(oKeys(i), oDict.Item(oKeys(i)))
    Next
End Function
Public Sub QuickSort(ByRef oDict, ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Long
    Dim varSwap As Variant

    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    varMid = oDict.Item(pvarArray((plngLeft + plngRight) \ 2))
    Do
        Do While oDict.Item(pvarArray(lngFirst)) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < oDict.Item(pvarArray(lngLast)) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            Set varSwap = pvarArray(lngFirst)
            Set pvarArray(lngFirst) = pvarArray(lngLast)
            Set pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort oDict, pvarArray, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort oDict, pvarArray, lngFirst, plngRight
End Sub

归功于 vbforums 用于排序算法