Question : VBA code to determine Bookmark name and copy it.

I have a macro code in MS Word that inserts a row below an existing row in Table 1, and inserts a bookmarked text form field into one of the cells of the inserted row. The macro then jumps to Table 2, a few pages further into the document, and inserts a row below an existing row containing data correlating to the inserted Table 1 row. I need the macro to code into one the newly inserted Table 2 row cells a reference bookmark to the inserted form field in the Table 1 row so that when data is entered into the Table 1 form field it will also populate into the Table 2 cell.

This process of row insertions may be repeated many, many times in the same document and it is impossible to manually assign the bookmark names each time. The code must copy the name of the text formfield bookmark and use this as the reference bookmark name.

The basic code format I'm using is:

To Find the Bookmark Name - I think?

strFieldName = Selection.FormFields(1).Name
Copy???

To insert the copied name into the reference bookmark:

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="Ref "
Selection.Paste

Your help in this coding problem would be very greatly appreciated.

Thanks,

Michael

Answer : VBA code to determine Bookmark name and copy it.

You had embedded the Function inside the Sub. It is fundamental that procedures are not put inside one another. This is the corrected code for the whole module.

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:

           
           
             Option Explicit
 
Sub InsertLine1()
    Dim wrdDoc As Word.Document
    Dim wrdTable1 As Word.Table
    Dim wrdTable2 As Word.Table
    Dim wrdRow1 As Word.Row
    Dim wrdRow1a As Word.Row
    Dim wrdRow2 As Word.Row
    Dim wrdRange As Word.Range
    Dim wrdCell As Word.Cell
    Dim f As Integer
    Dim c As Integer
    Dim wrdField As Word.Field
    Dim wrdFormField1 As Word.FormField
    Dim wrdFormField2 As Word.FormField
    Dim strTitle As String
    Dim strNewTitle As String
    
    'table 1 contains the selection
    Set wrdTable1 = Selection.Tables(1)
    strTitle = GetCellText(wrdTable1.Range.Cells(1))
    strNewTitle = Replace(strTitle, "MP ", "PW ")
    'find matching table
    For Each wrdTable2 In ActiveDocument.Tables
        If GetCellText(wrdTable2.Range.Cells(1)) = strNewTitle Then
            Exit For
        End If
    Next wrdTable2
    'debugging message
    If wrdTable2 Is Nothing Then
        MsgBox "Matching table not found"
        Exit Sub
    End If
    '...
    Set wrdDoc = ActiveDocument
    Set wrdRow1 = wrdTable1.Rows.Last
    wrdDoc.Unprotect 'password
    Set wrdRange = wrdRow1.Range
    'add row and form fields to first table
    Set wrdRow1a = wrdTable1.Rows.Add
    For f = 1 To wrdRow1.Range.FormFields.Count
        Set wrdFormField1 = wrdRow1.Range.FormFields(f)
        Set wrdCell = wrdFormField1.Range.Cells(1)
        c = wrdCell.ColumnIndex
        Set wrdRange = wrdRow1a.Cells(c).Range
        wrdRange.Collapse wdCollapseStart
        Set wrdFormField2 = wrdDoc.FormFields.Add(wrdRow1a.Cells(c).Range, wrdFormField1.Type)
    Next f
    'Add row and ref fields to second table
    Set wrdRow2 = wrdTable2.Rows.Add
    For f = 1 To wrdRow1a.Range.FormFields.Count
        Set wrdFormField2 = wrdRow1a.Range.FormFields(f)
        wrdFormField2.CalculateOnExit = True
        Set wrdCell = wrdFormField2.Range.Cells(1)
        c = wrdCell.ColumnIndex
        Set wrdRange = wrdRow2.Cells(c).Range
        wrdRange.Collapse wdCollapseStart
        Set wrdField = wrdDoc.Range.Fields.Add(wrdRange, , "REF " & wrdFormField2.Name)
        Set wrdFormField2 = Nothing
    Next f
    wrdDoc.Protect wdAllowOnlyFormFields, True ',password
End Sub
    
Function GetCellText(cel As Word.Cell) As String
    Dim rng As Range
    
    Set rng = cel.Range
    rng.MoveEnd wdCharacter, -1
    GetCellText = Trim$(rng.Text)
End Function
           
         

Open in New Window Select All