Question

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

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

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

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的排序算法

如何使Word表格与VBA整齐地匹配页面

1 个答案: