[求助]请教统一表格列宽问题

duke008

文档中有很多（几百个）如下形式的表格，但是它们的列宽并不统一，现在我要统一它们的列宽，

我自己写了一个vba程序，但是运行效率不是很高。不知道有什么更好的方法？

Sub columnswidth()
'统一表格的列宽
Dim r As Integer, w1 As Integer, w2 As Integer, w3 As Integer, w4 As Integer, i As Integer
w1 = CentimetersToPoints(2.65) '设置第一列宽度
w2 = CentimetersToPoints(5.3)  '设置第二列宽度
w3 = CentimetersToPoints(2.65) '设置第三列宽度
w4 = CentimetersToPoints(5)    '设置第四列宽度

For i = 1 To ActiveDocument.Tables.Count
With ActiveDocument.Tables(i)

If InStr(.Cell(1, 1).Range, "Publication:") <> 0 Then‘第一个单元格中包含"Publication:"的表格是需要处理的表格

.Select
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
For r = 1 To .Rows.Count - 1
.Cell(r, 1).Width = w1
.Cell(r, 2).Width = w2
.Cell(r, 3).Width = w3
.Cell(r, 4).Width = w4
Next r
.Cell(.Rows.Count, 1).Width = w1
.Cell(.Rows.Count, 2).Width = w2 + w3 + w4
End If
End With
Next i
End Sub

konggs

简单的改了一下。你看看。

Sub konggs1()
'统一表格的列宽
Dim c%, arr(3), i%
Dim atable As Table
Dim arange As Range
Application.ScreenUpdating = False

On Error Resume Next
    arr(0) = CentimetersToPoints(2.65) '设置第一列宽度
    arr(1) = CentimetersToPoints(5.3)   '设置第二列宽度
    arr(2) = CentimetersToPoints(2.65)  '设置第三列宽度
    arr(3) = CentimetersToPoints(5)     '设置第四列宽度
For Each atable In ActiveDocument.Tables
 With atable
    If InStr(.Cell(1, 1).Range, "Publication:") <> 0 Then '第一个单元格中包含"Publication:"的表格是需要处理的表格
    End If
    For c = 4 To 1 Step -1
    Set arange = ActiveDocument.Range(.Cell(1, c).Range.Start, .Cell(1, c).Range.Start)
        arange.Select
        With Selection
            .SelectColumn
            .Cells.SetWidth columnwidth:=arr(c - 1), rulerstyle:=wdAdjustNone
        End With
    Next
    .Cell(.Rows.Count, 2).Width = arr(1) + arr(2) + arr(3)
 End With
Next

Application.ScreenUpdating = True
End Sub