Control column width (VBA)

[Robie]

Hi

I am currently taking Excel output and creating Word tables from it using VBA. Basically, one large columned output from Excel is divided into several tables at certain point. This all works fine.

1. One of the new requirements is that Column 1 text must *not* wrap around, i.e. the width of the column must be atleast as large as its biggest element.
2. Also, they want to make sure that the last column is as wide as possible so that it can have very long sentences without wrapping.
3. They also want to make sure that the table fits the window.

They are not asking for much are they. :(. Now, is there anyway I can control widths of individual columns and also at the same time make the table fit the window width?

Thanks.
Robie

[HansV]

1) How many columns do the tables have?
2) How narrow can the columns between the first and last one be made to allow the last column to be "as wide as possible"?

[Robie]

1) How many columns do the tables have?
2) How narrow can the columns between the first and last one be made to allow the last column to be "as wide as possible"?

Thanks for the response Hans.

1. This table has 7 columns in total.
2. 2nd-6th columns can be as small as possible. I have attached a sample table with actual column headings. Hope this helps.

Thanks.

[HansV]

I tried to write a macro for this but I gave up. Even when I told Word to autofit the first column, it didn't. And if I set the width of the first column explicitly, it would change as soon as I changed the width of another column even though I specified that the rest shouldn't change. Sorry.

[macropod]

Perhaps:

Code: Select all

Sub Demo()
Application.ScreenUpdating = True
Dim wdRng As Word.Range, wdTbl As Word.Table, i As Long
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object
Dim sLeft As Single, sRight As Single, sGutter As Single
Dim sPgWdth As Single, sPrnWdth As Single, sTblWdth As Single
'Start an Excel session with an empty workbook & worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlWkBk = xlApp.WorkBooks.Add
Set xlWkSht = xlWkBk.Worksheets(1)
With ActiveDocument
  Set wdRng = .Tables(1).Range
  'Cut & paste the table into Excel
  With wdRng
    .Cut
    '.Tables(1).Delete
  End With
  With xlWkSht
    .Paste Destination:=.Range("A1")
    'Reformat the table, then make a copy
    With .UsedRange
      .WrapText = False
      .Columns.AutoFit
      .Copy
    End With
  End With
  'Terminate our Excel session
  With xlApp
    .DisplayAlerts = False
    xlWkBk.Close False
    .DisplayAlerts = True
    .Quit
  End With
  ' Release Excel object memory
  Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
  'Paste the table back into Word
  wdRng.Paste
  Set wdTbl = wdRng.Tables(1)
  'Adjust the last column's width
  With .Sections(wdTbl.Range.Information(wdActiveEndSectionNumber)).PageSetup
    sLeft = .LeftMargin
    sRight = .RightMargin
    sGutter = .Gutter
    sPgWdth = .PageWidth
  End With
  sPrnWdth = sPgWdth - sLeft - sRight - sGutter
  With wdTbl
    .AllowAutoFit = False
    .PreferredWidth = 0
    .PreferredWidthType = wdPreferredWidthPoints
    For i = 1 To .Columns.Count
      sTblWdth = sTblWdth + .Columns(i).Width
    Next
    .Columns(.Columns.Count).Width = .Columns(.Columns.Count).Width + sPrnWdth - sTblWdth
  End With
End With
Application.ScreenUpdating = True
End Sub

[macropod]

Alternatively, to reduce the copy/paste overheads & formatting issues associated with that process:

Code: Select all

Sub Demo()
Application.ScreenUpdating = True
Dim wdRng As Word.Range, wdTbl As Word.Table, i As Long
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object
Dim sLeft As Single, sRight As Single, sGutter As Single
Dim sPgWdth As Single, sPrnWdth As Single, sTblWdth As Single
'Start an Excel session with an empty workbook & worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlWkBk = xlApp.WorkBooks.Add
Set xlWkSht = xlWkBk.Worksheets(1)
With ActiveDocument
  Set wdRng = .Tables(1).Range
  'Cut & paste the table into Excel
  With wdRng
    .Copy
  End With
  With xlWkSht
    .Paste Destination:=.Range("A1")
    'Reformat the table, then make a copy
    With .UsedRange
      .WrapText = False
      .Columns.AutoFit
    End With
  End With
  Set wdTbl = wdRng.Tables(1)
  'Adjust the last column's width
  With .Sections(wdTbl.Range.Information(wdActiveEndSectionNumber)).PageSetup
    sLeft = .LeftMargin
    sRight = .RightMargin
    sGutter = .Gutter
    sPgWdth = .PageWidth
  End With
  sPrnWdth = sPgWdth - sLeft - sRight - sGutter
  With wdTbl
    .AllowAutoFit = False
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = 0
    .LeftPadding = 0
    .RightPadding = 0
    For i = 1 To .Range.Cells.Count
      With .Range.Cells(i)
        .LeftPadding = 0
        .RightPadding = 0
      End With
    Next
    For i = 1 To .Columns.Count
      With .Columns(i)
        .PreferredWidthType = wdPreferredWidthPoints
        .PreferredWidth = 0
        .Width = xlWkSht.Columns(i).Width
      End With
      sTblWdth = sTblWdth + .Columns(i).Width
    Next
    .Columns(.Columns.Count).Width = .Columns(.Columns.Count).Width + sPrnWdth - sTblWdth
  End With
  'Terminate our Excel session
  With xlApp
    .DisplayAlerts = False
    xlWkBk.Close False
    .DisplayAlerts = True
    .Quit
  End With
End With
  ' Release Excel object memory
  Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub

[Robie]

Alternatively, to reduce the copy/paste overheads & formatting issues associated with that process:

Code: Select all

Sub Demo()
Application.ScreenUpdating = True
Dim wdRng As Word.Range, wdTbl As Word.Table, i As Long
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object
Dim sLeft As Single, sRight As Single, sGutter As Single
Dim sPgWdth As Single, sPrnWdth As Single, sTblWdth As Single
'Start an Excel session with an empty workbook & worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlWkBk = xlApp.WorkBooks.Add
Set xlWkSht = xlWkBk.Worksheets(1)
With ActiveDocument
  Set wdRng = .Tables(1).Range
  'Cut & paste the table into Excel
  With wdRng
    .Copy
  End With
  With xlWkSht
    .Paste Destination:=.Range("A1")
    'Reformat the table, then make a copy
    With .UsedRange
      .WrapText = False
      .Columns.AutoFit
    End With
  End With
  Set wdTbl = wdRng.Tables(1)
  'Adjust the last column's width
  With .Sections(wdTbl.Range.Information(wdActiveEndSectionNumber)).PageSetup
    sLeft = .LeftMargin
    sRight = .RightMargin
    sGutter = .Gutter
    sPgWdth = .PageWidth
  End With
  sPrnWdth = sPgWdth - sLeft - sRight - sGutter
  With wdTbl
    .AllowAutoFit = False
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = 0
    .LeftPadding = 0
    .RightPadding = 0
    For i = 1 To .Range.Cells.Count
      With .Range.Cells(i)
        .LeftPadding = 0
        .RightPadding = 0
      End With
    Next
    For i = 1 To .Columns.Count
      With .Columns(i)
        .PreferredWidthType = wdPreferredWidthPoints
        .PreferredWidth = 0
        .Width = xlWkSht.Columns(i).Width
      End With
      sTblWdth = sTblWdth + .Columns(i).Width
    Next
    .Columns(.Columns.Count).Width = .Columns(.Columns.Count).Width + sPrnWdth - sTblWdth
  End With
  'Terminate our Excel session
  With xlApp
    .DisplayAlerts = False
    xlWkBk.Close False
    .DisplayAlerts = True
    .Quit
  End With
End With
  ' Release Excel object memory
  Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub

Thanks Paul. I will give this one a go and let you know how I get on.

[Robie]

I tried to write a macro for this but I gave up. Even when I told Word to autofit the first column, it didn't. And if I set the width of the first column explicitly, it would change as soon as I changed the width of another column even though I specified that the rest shouldn't change. Sorry.

No worries Hans. I am going to try Paul's suggestion.