CODEWITHSUNDEEP
vbams-word
Kundan Bhati
Kundan Bhati

Reputation: 505

How to insert cross-reference in table cell in word vba

I want to insert cross-reference in cell 1 and 2 of each row in table. but cross-reference is going to only cell 1. even cell 2 cross-reference is going to cell 1. following is the code and see the attached image, please suggest solution. I tried to move cursor in cells but that does not seem to work. enter image description here

Private Sub CmdGenerateTable_Click()
On Error GoTo ErrHandler
Dim objTable As Word.Table
Dim i As Integer, n As Integer, xRefs As Variant
Dim rng As Word.Range

Set rng = ActiveDocument.Bookmarks("HeadingsTable").Range

If rng.Tables.Count > 0 Then
    rng.Tables(1).Delete
End If

Application.ScreenUpdating = False

'Get the CrossReferenceItems collection
xRefs = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)

Set objTable = rng.Tables.Add(rng, UBound(xRefs) + 1, 5)

objTable.Borders.Enable = True

objTable.Cell(1, 1).Range.Text = "Heading #"
objTable.Cell(1, 2).Range.Text = "Heading Text"
objTable.Cell(1, 3).Range.Text = "reserved"
objTable.Cell(1, 4).Range.Text = "reserved"
objTable.Cell(1, 5).Range.Text = "reserved"

For i = 2 To UBound(xRefs) + 1       

''Trying to insert cross reference in first cell 
      objTable.Cell(i, 1).Range.Select
        Selection.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
                                                        wdNumberRelativeContext, ReferenceItem:=i - 1, InsertAsHyperlink:=True, _
                                                        IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "


''Trying to insert cross reference in second cell         
        objTable.Cell(i, 2).Range.Select
        Selection.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
                                                        wdContentText, ReferenceItem:=i - 1, InsertAsHyperlink:=True, _
                                                        IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "



Next

Application.ScreenUpdating = True

Exit Sub
ErrHandler:
    MsgBox ("Line number: " + Erl + ", Description: " + Err.Description + ", Error number: " + Err.Number)
End Sub

Upvotes: 0

Views: 1392

Answers (1)

Cindy Meister
Cindy Meister

Reputation: 25663

I don't know why Selection is behaving the way it does - I see it too. But working with the Range object does work correctly. I added two Range variables to your code, set them to the two cells in the For loop and substituted them for Selection. This worked for me:

Sub CmdGenerateTable_Click()
    On Error GoTo ErrHandler
    Dim objTable As Word.Table
    Dim i As Integer, n As Integer, xRefs As Variant
    Dim rng As Word.Range
    Dim rngCel1 As Word.Range
    Dim rngCel2 As Word.Range

    ActiveDocument.Bookmarks("HeadingsTable").Range

    If rng.Tables.Count > 0 Then
        rng.Tables(1).Delete
    End If

    Application.ScreenUpdating = False

    'Get the CrossReferenceItems collection
    xRefs = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)

    Set objTable = rng.Tables.Add(rng, UBound(xRefs) + 1, 5)

    objTable.Borders.Enable = True

    objTable.Cell(1, 1).Range.Text = "Heading #"
    objTable.Cell(1, 2).Range.Text = "Heading Text"
    objTable.Cell(1, 3).Range.Text = "reserved"
    objTable.Cell(1, 4).Range.Text = "reserved"
    objTable.Cell(1, 5).Range.Text = "reserved"

    For i = 2 To UBound(xRefs) + 1
         Set rngCel1 = objTable.Cell(i, 1).Range
         rngCel1.Collapse wdCollapseStart
         Set rngCel2 = objTable.Cell(i, 2).Range
         rngCel2.Collapse wdCollapseStart
    ''Trying to insert cross reference in first cell
            rngCel1.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
                                                            wdNumberRelativeContext, ReferenceItem:=i - 1, InsertAsHyperlink:=True, _
                                                            IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "

    ''Trying to insert cross reference in second cell
            rngCel2.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
                             wdContentText, ReferenceItem:=i - 1, InsertAsHyperlink:=True, _
                             IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
    Next

    Application.ScreenUpdating = True

Exit Sub
ErrHandler:
    MsgBox ("Line number: " + Erl + ", Description: " + Err.Description + ", Error number: " + Err.Number)
End Sub

Upvotes: 1

Related Questions