Select the first row of each cell in a table and Bold it. Leaving the rest of the cell normal

Question

Hello,

I have designed a program to pull a column Concatenated data from excel and paste it into two columns in Word. I am looking to have the first row in each cell bold and the rest of the cell to be normal. Below is my code, with the part I have attempt to bold the first 18 characters (thats how many characters are in each row). Could Someone help me out?

Sub Drawings()

Dim WordApp As Word.Application
Dim oDoc As Word.Document
Dim myRange As Word.Range
Dim RowCount
Dim RowNumber
Dim Row
Dim rng As Range

Set rng = ActiveCell

RowCount = Application.CountA(Range("A:A"))
RowNumber = Round(RowCount / 2)

Set WordApp = CreateObject("Word.Application") ' creates the Woord Applications
WordApp.Visible = True ' allows the word window to be open

Set oDoc = WordApp.Documents.Add ' WordDoc is the variable to edit the document

Set otable = oDoc.Tables.Add( _
    Range:=oDoc.Range(Start:=0, End:=0), NumRows:=RowNumber + 1, _
    NumColumns:=3) ' adds a table with three columns and spe

oDoc.Tables(1).Columns(1).SetWidth ColumnWidth:=WordApp.CentimetersToPoints(10.1), RulerStyle:=wdAdjustNone ' sets column 1 to 4 inches
oDoc.Tables(1).Columns(2).SetWidth ColumnWidth:=WordApp.CentimetersToPoints(0.45), RulerStyle:=wdAdjustNone ' sets column 2 to .2 inches
oDoc.Tables(1).Columns(3).SetWidth ColumnWidth:=WordApp.CentimetersToPoints(10.1), RulerStyle:=wdAdjustNone ' sets column 3 to 4 inches


With oDoc.PageSetup
.LeftMargin = WordApp.CentimetersToPoints(0.2)  ' sets left margin
.RightMargin = WordApp.CentimetersToPoints(0.5)  ' sets right margin
.TopMargin = WordApp.CentimetersToPoints(0.5) 'sets top margin
.BottomMargin = WordApp.CentimetersToPoints(0.5) ' sets bottom margin
End With

 'Loop through columns and rows
   For iRow = 2 To RowNumber
    For iCol = 1 To 1 ' takes data from column 1
        With Worksheets("Sheet1").Cells(iRow, iCol)
            otable.Rows(iRow - 1).Cells(1).Range.Text = .Value
        End With
    Next iCol
    Next iRow
    
    For iRow = RowNumber + 1 To RowCount
     For iCol = 1 To 1 ' takes data from column 1
            With Worksheets("Sheet1").Cells(iRow, iCol)
            otable.Rows(iRow - RowNumber).Cells(3).Range.Text = .Value
        End With
    
    Next iCol
    Next iRow
   
With otable
    .Rows.HorizontalPosition = WordApp.CentimetersToPoints(0.5)  ' shifts left up on the page
    .Rows.VerticalPosition = WordApp.CentimetersToPoints(0.75) ' shifts down up on the page

End With
    
    WordApp.Selection.WholeStory ' selects the entire table
    'WordApp.Selection.Font.Bold = wdToggle ' bolds the text
    WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 'center aligns everything
    WordApp.Selection.Font.Size = 13.7
    
    
    With otable
    For Each MyCell In Range("A:B") ' step through each cell in the table
        WordApp.Selection.MoveRight Unit:=wdCharacter, Count:=18, Extend:=wdExtend ' select first 18 characters of cell
        WordApp.Selection.Font.Bold = wdToggle ' bold the selected characters
    Next MyCell ' move to next cell
    End With
    
    WordApp.Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    oDoc.Tables(1).Rows.HeightRule = wdRowHeightExactly ' ensures row height is exact
    oDoc.Tables(1).Rows.Height = WordApp.InchesToPoints(1) ' sets all rows to 1 inch

End Sub

Thanks

Answer 1

Hi,

>>I am looking to have the first row in each cell bold and the rest of the cell to be normal. Below is my code, with the part I have attempt to bold the first 18 characters (thats how many characters are in each row).<<

According to the code your provided, I don't understand why you need to loop through all cells in the Range("A:B") of the workbook but you said "step through each cell in the table".

With otable
    For Each MyCell In Range("A:B") ' step through each cell in the table
        WordApp.Selection.MoveRight Unit:=wdCharacter, Count:=18, Extend:=wdExtend ' select first 18 characters of cell
        WordApp.Selection.Font.Bold = wdToggle ' bold the selected characters
    Next MyCell ' move to next cell
    End With

If you want to access to all cells in a table, you could refer to the code below.

For Each  oRow  In  otable.Rows 
     For Each  oCell  In  oRow.Cells 
         'operate oCell
     Next oCell 
 Next oRow 

To bold the first row (first 18 characters) in a cell of table, you could refer to the bold part in the code below. In the code, it will bold the first 18 characters in each cell of column 1 and 3. You could edit it as you want to achieve the goal.

    'With otable
    'For Each MyCell In Range("A:B") ' step through each cell in the table
        'WordApp.Selection.MoveRight Unit:=wdCharacter, Count:=18, Extend:=wdExtend ' select first 18 characters of cell
        'WordApp.Selection.Font.Bold = wdToggle ' bold the selected characters
    'Next MyCell ' move to next cell
    'End With

    WordApp.Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    oDoc.Tables(1).Rows.HeightRule = wdRowHeightExactly ' ensures row height is exact
    oDoc.Tables(1).Rows.Height = WordApp.InchesToPoints(1) ' sets all rows to 1 inch

    For Each oRow In otable.Rows
        For Each MyCell In oRow.Cells
            If MyCell.ColumnIndex <> 2 Then
                MyCell.Select
                WordApp.Selection.Collapse wdCollapseStart
                WordApp.Selection.MoveRight Unit:=wdCharacter, Count:=18, Extend:=wdExtend ' select first 18 characters of cell
                WordApp.Selection.Font.Bold = wdToggle ' bold the selected characters
            End If
        Next MyCell
    Next oRow
    
End Sub

---

We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
Click HERE to participate the survey.

Answer 2

Try:

Sub Drawings()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Dim wdTbl As Word.Table
Dim iRow As Long, lRow As Long
Dim xlWkSht As Worksheet
Set xlWkSht = Worksheets("Sheet1")

With xlWkSht.UsedRange
  lRow = Int(.Range("A" & .Rows.Count).End(xlUp).Row / 2)
End With

Set wdApp = CreateObject("Word.Application") ' creates the Word Applications

Set wdDoc = wdApp.Documents.Add ' WordDoc is the variable to edit the document

With wdDoc.PageSetup
  .LeftMargin = wdApp.CentimetersToPoints(0.2)  ' sets left margin
  .RightMargin = wdApp.CentimetersToPoints(0.5)  ' sets right margin
  .TopMargin = wdApp.CentimetersToPoints(0.5) 'sets top margin
  .BottomMargin = wdApp.CentimetersToPoints(0.5) ' sets bottom margin
End With

Set wdTbl = wdDoc.Tables.Add(Range:=wdDoc.Range(Start:=0, End:=0), _
    NumRows:=lRow + 1, NumColumns:=3) ' adds a table with three columns and spe

With wdTbl
  .Columns(1).SetWidth ColumnWidth:=wdApp.InchesToPoints(4), RulerStyle:=wdAdjustNone ' sets column 1 to 4 inches
  .Columns(2).SetWidth ColumnWidth:=wdApp.InchesToPoints(0.2), RulerStyle:=wdAdjustNone ' sets column 2 to .2 inches
  .Columns(3).SetWidth ColumnWidth:=wdApp.InchesToPoints(4), RulerStyle:=wdAdjustNone ' sets column 3 to 4 inches
  With .Rows
    .HorizontalPosition = wdApp.CentimetersToPoints(0.5)  ' shifts left up on the page
    .VerticalPosition = wdApp.CentimetersToPoints(0.75) ' shifts down up on the page
    .HeightRule = wdRowHeightExactly ' ensures row height is exact
    .Height = wdApp.InchesToPoints(1) ' sets all rows to 1 inch
  End With
  With .Range
    .ParagraphFormat.Alignment = wdAlignParagraphCenter 'center aligns everything
    .Font.Size = 13.5
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  .Rows(1).Range.Font.Bold = True
End With

'Loop through columns and rows
For iRow = 2 To lRow
  wdTbl.Rows(iRow - 1).Cells(1).Range.Text = xlWkSht.Cells(iRow, 1).Value
  wdTbl.Rows(iRow - 1).Cells(3).Range.Text = xlWkSht.Cells(iRow * 2, 1).Value
Next iRow

' Show the Word window
wdApp.Visible = True
wdApp.Activate
End Sub

Note that I've streamlined the code somewhat. For example, your 'For iCol = 1 To 1' code does nothing useful.

---

Cheers
Paul Edstein
[MS MVP - Word]