VBA para crear una tabla de Word con bordes

VBA

Módulo estándar

Cuando se desea escribir información tabular en Word, la creación de una tabla para almacenar los datos funciona a la perfección. El procedimiento WordMakeTable_s4p devuelve el objeto de tabla que se acaba de crear.

La tabla es una matriz bidimensional y cada celda se puede referenciar con:

oTable.cell(RowNumber, ColumnNumber).Range.Text = "whatever you want"

Dónde:

oTable es la referencia del objeto para la tabla

RowNumber, ColumnNumber es el número entero largo de fila y columna

'*************** Code Start *****************************************************
' module name: mod_Word_MakeTable_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to create a table in Word
'              send document and range objects
'              specify number of rows and columns
'              optionally add Caption
'              optionally add borders and shading to first row
'              optionally send column headings
' Author   : crystal (strive4peace)
' Code List: www.MsAccessGurus.com/code.htm
' This code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           WordMakeTable_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function WordMakeTable_s4p(oDoc As Object _ 
   ,oRange As Object _ 
   ,ByVal pnRows As Long _ 
   ,ByVal pnCols As Long _ 
   ,Optional ByVal psCaption As String =  "" _ 
   ,Optional pbDoBorders As Boolean = True _ 
   ,Optional ByVal paHeadArray As Variant _ 
   ) As Object  'As Word.Table
'strive4peace 170811, 20202, 220420, 230619 array headings, 22
   ' PARAMETERS
   '  oDoc os the document object
   '  oRange is a range object where to insert table
   '  pnRows is a long integer number of rows
   '  pnCols is a long integer number of columns
   ' OPTIONAL
   '  psCaption os a caption -- start with space or period space
   '  pbDoBorders = True to add borders and shading for the first row
   '  paHeadArray os a vriant array with column headings
   
   'early binding
'   Dim oTable As Word.Table

   'late binding
   Dim oTable As Object 
   
   Dim i As Integer _ 
      ,iCol As Integer 
   
   'insert table
   With oDoc 
      Set oTable = .Tables.Add( _ 
         Range:=oRange _ 
         ,NumRows:=pnRows _ 
         ,NumColumns:=pnCols _ 
         ) 

   End With 
 
   If (psCaption   "") Then 
      'insert caption
      oDoc.Application.Selection.InsertCaption _ 
            Label:= "Table" _ 
            ,Title:=psCaption _ 
            ,Position:=0 _ 
            ,ExcludeLabel:=0 
   End If 
      
   With oTable 
      'Position - wdCaptionPositionAbove=0
'      .ApplyStyleHeadingRows = True
      .TopPadding = 0 
      .BottomPadding = 0 
      .LeftPadding = 2  'points
      .RightPadding = 2 
      .Spacing = 0  'Auto
      .AllowPageBreaks = True 
      .AllowAutoFit = False 

      'dont allow rows to break
      .Rows.AllowBreakAcrossPages = False 
 
      'no space above text between paragraphs
      .Range.Paragraphs.SpaceBefore = 0 
 
      'Vertical Alignment is Center
      .Range.Cells.VerticalAlignment = 1  ' 1=wdCellAlignVerticalCenter
 
      'Heading Row
      If Not IsMissing(paHeadArray) Then 
         'mark heading row
         .Rows(1).HeadingFormat = True 
         iCol = 1 
         For i = LBound(paHeadArray) To UBound(paHeadArray) 
            .Cell(1,iCol).Range.Text = paHeadArray(i) 
            iCol = iCol + 1 
         Next i  'array element
      End If 
      
      If pbDoBorders Then 
         Call WordTableBorders_s4p(oTable) 
      End If 
      
      'best-fit columns
      .Columns.AutoFit 
         
   End With 
 
   Set WordMakeTable_s4p = oTable 
 
End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           WordTableBorders_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Object is 'Word.Table
Public Sub WordTableBorders_s4p(oTable As Object) 
's4p 170811
   Dim i As Integer 
   With oTable 
      For i = 1 To 6 
         'wdBorderTop =-1
         'wdBorderLeft = -2
         'wdBorderBottom =-3
         'wdBorderRight= -4
         'wdBorderHorizontal = -5
         'wdBorderVertical = -6
         With .Borders(-i) 
            .LineStyle = 1   'wdLineStyleSingle=1
            .LineWidth = 8  'wdLineWidth100pt=8. wdLineWidth150pt=12
            .Color = RGB(200,200,200)  'medium-light gray
         End With 
      Next i 
   End With 
   'change borders to black for first row
   With oTable.Rows(1) 
      For i = 1 To 4 
         With .Borders(-i) 
            .Color = 0       'wdColorBlack = 0
         End With 
      Next i 
      'Shading for header row
      .Shading.BackgroundPatternColor = RGB(232,232,232) 
   End With  'first row
   'Not used:
'      'wdLineStyleNone = 0
'      .Borders(-7).LineStyle = 0 'wdBorderDiagonalDown =-7
'      .Borders(-8).LineStyle = 0 'wdBorderDiagonalUp =-8
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           test_WordMakeTable
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'mod_test_WordMakeTable_s4p
Public Sub test_WordMakeTable() 
'230619 s4p
' make a table where the cursor is in the active document,
'  in a new next paragraph

   'CLICK HERE
   'Press F5 to run for ActiveDocument
   
   Dim oRange As Word.Range 
   
   Dim nRows As Long _ 
      ,nCols As Long _ 
      ,i As Integer _ 
      ,sCaption As String 
      
   '------------------------- CUSTOMIZE!
   Dim aHeadings(1 To 4) As Variant 
   nRows = 2 
   nCols = 4 
   '-------------------------
   
   sCaption =  " Table containing " _ 
      & nRows &  " rows, and " _ 
      & nCols &  " columns" _ 
      &  " with borders and best-fit columns"
      
   'make up fake column names
   For i = 1 To nCols 
      aHeadings(i) =  "Column " & i 
      'make heading longer for last column
      If i = nCols Then 
         aHeadings(nCols) = aHeadings(nCols) _ 
            &  " is a description so it's wider"
      Else 
         aHeadings(nCols) = aHeadings(nCols) _ 
            &  " Heading"
      End If 
   Next i 
   
   '-------------------------
   'collapse to end of selection
   Set oRange = Selection.Range 
   With oRange 
      .Collapse 0  'wdCollapseEnd
      'insert new paragraph
      .InsertParagraphAfter 
      .Collapse 0  'wdCollapseEnd
   End With 
   
   'make table with caption, with borders, heading labels
   Call WordMakeTable_s4p( _ 
      ActiveDocument _ 
      ,oRange _ 
      ,nRows _ 
      ,nCols _ 
      ,sCaption,True,aHeadings) 
   
   MsgBox  "Done making table",, "Done"
   
End Sub 
'*************** Code End *******************************************************